Extract icalendar fixtures in emacs

calsync-extract-icalendar-fixtures.el

(defvar calsync-extract-icalendar-fixtures--fixture-regexp
  "<<-?\\(\\w+\\)\n\\(\\(.*\\\\r\n\\)*\\)\\1")

(defun calsync-extract-icalendar-fixtures ()
  "Extracts heredocs into icalendar fixtures."
  (interactive)
  (let ((offer-ids (calsync-extract-icalendar-fixtures--offer-ids))
        (fixture-dir
         (format "%s/%s" (expand-file-name "../fixtures/icalendar")
                 (calsync-extract-icalendar-fixtures--find-cassette-name))))

    (make-directory fixture-dir t)

    (save-excursion
      (mapc
       (lambda (args)
         (apply 'calsync-extract-icalendar-fixtures--write-fixture
                fixture-dir args))
       (calsync-extract-icalendar-fixtures--delete-fixtures offer-ids))))
  nil)

(defun calsync-extract-icalendar-fixtures--write-fixture (fixture-dir offer-id fixture)
  (with-temp-file (format "%s/%s.ics" fixture-dir offer-id)
    (insert fixture)
    (goto-char (point-min))
    (while (search-forward "\\r" nil t)
      (replace-match ""))
    (set-buffer-file-coding-system 'dos)))

(defun calsync-extract-icalendar-fixtures--find-cassette-name ()
  (save-excursion
    (goto-char (point-min))
    (search-forward "cassette_name: ")
    (re-search-forward "\\s\"\\(\\S\"*\\)\\s\"")
    (buffer-substring-no-properties
     (match-beginning 1) (match-end 1))))

(defun calsync-extract-icalendar-fixtures--offer-ids ()
  (interactive)
  (let (offer-ids)
    (save-excursion
      (goto-char (point-min))
      (while (re-search-forward calsync-extract-icalendar-fixtures--fixture-regexp nil t)
        (let* ((beg (match-beginning 1))
               (end (match-end 1))
               (overlay (make-overlay beg end)))
          (goto-char beg)
          (recenter)
          (overlay-put overlay 'face 'highlight)
          (push (read-string (format "offer id: ")) offer-ids)
          (remove-overlays beg end)
          (goto-char end))))
    (nreverse offer-ids)))

(defun calsync-extract-icalendar-fixtures--delete-fixtures (offer-ids)
  (save-excursion
    (let (fixtures)
      (goto-char (point-min))
      (while
          (re-search-forward calsync-extract-icalendar-fixtures--fixture-regexp nil t)
        (let ((fixture (buffer-substring-no-properties
                        (match-beginning 2) (match-end 2)))
              (offer-id (car offer-ids)))
          (push (list offer-id fixture) fixtures)
          (setq offer-ids (cdr offer-ids))
          (replace-match (format "icalendar(%s)" offer-id) nil t)))
      fixtures)))

(provide 'calsync-extract-icalendar-fixtures)