;;; html-move.el --- Move a file in a local file web site.
;;
;; Author: Lennart Borgman (lennart O borgman A gmail O com)
;; Created: Thu Jan 12 08:11:30 2006
(defconst html-move:version "0.31") ;; Version:
;; Last-Updated: Tue Feb 20 23:59:43 2007 (3600 +0100)
;; Keywords:
;; Compatibility:
;;
;; Features that might be required by this library:
;;
;;   None
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;;DO NOT USE YET!
;;
;;  Functions for moving a file in a local file web site. Moves the
;;  file and fixes the local affected links after the move.
;;
;;  To use this file you may in your .emacs put
;;
;;      (require 'html-move)
;;
;;  Call the function `html-move-buffer-file' to move a file.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Change log:
;;
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Code:

(eval-when-compile (add-to-list 'load-path default-directory load-path))
(eval-when-compile (require 'html-site nil t))
(require 'url-parse)

(defun html-move-make-new-url (old-url from-dir to-dir)
  "Make new relative url.
If OLD-URL is an absolute path then return it.  Otherwise OLD-URL
is assumed to be relative FROM-DIR. Return a new url relative
TO-DIR that gives the same absolute path."
  (if (or (file-name-absolute-p old-url)
          (char-equal ?# (string-to-char old-url))
          (let ((urlobj (url-generic-parse-url old-url)))
            (url-host urlobj)))
      (progn
        nil)
    (let* (
           (relative-path (file-relative-name from-dir to-dir))
           (new-abs-url (expand-file-name (concat relative-path old-url) to-dir))
           (new-url (file-relative-name new-abs-url to-dir)))
      new-url)))


(defun html-move-in-dir-tree (file tree)
  (let ((rel-path (file-relative-name file tree)))
    (or (string= "." rel-path)
        (not (string= ".." (substring rel-path 0 2))))))

(defun html-move-buffer-file (to)
  "Move current buffer file to another directory and/or name.
Correct the affected relative links in the moved file and the
links to the file moved in the directory tree
`html-site-current-site-dir'."
  ;;(interactive "GMove to: ")
  (interactive
    (let* ((use-dialog-box nil)
           (name (read-file-name "Move to (directory or file name): "
                                 ))
           )
      (list (expand-file-name name))))
  (html-site-current-ensure-site-defined)
  (let ((from (buffer-file-name))
        (site-directory (html-site-current-site-dir)))
    (unless from
      (error "No buffer file name, can't move file!"))
    (let* ((from-dir (file-name-directory from))
           (from-ext (file-name-extension from))
           to-dir
           to-ext
           new-name
           new-file
           new-buffer
           relative-path)
      (unless (html-move-in-dir-tree from-dir site-directory)
        (error "Buffer file is not in site directory tree"))
      (if (file-directory-p to)
          (progn
            (setq to-dir to)
            (setq new-name (file-name-nondirectory from))
            )
        (setq to-ext (file-name-extension to))
        (unless (string= to-ext from-ext)
          (if (not to-ext)
              (error "Can't find directory %s (or missing extension?)" to)
            (error "Move must not change file extension")))
        (setq to-dir (file-name-directory to))
        (unless (file-directory-p to-dir)
          (if (file-exists-p to-dir)
              (error "Not a directory: %s" to-dir)
            (error "Can't find directory %s" to-dir)))
        (setq new-name (file-name-nondirectory to))
        )

      (unless (html-move-in-dir-tree to-dir site-directory)
        (error "Target is not in site directory tree"))


      (setq relative-path (file-relative-name to-dir from-dir))
      (when (file-name-absolute-p relative-path)
        (error "Can't make a relative path from %s to %s" from to))
      (setq new-file (expand-file-name new-name to))
      (let ((moved-buffer (current-buffer))
            (moved-contents (buffer-substring-no-properties
                             (point-min)
                             (point-max))))
        (when (file-exists-p new-file)
          (error "File already exists: %s" new-file))
        ;; Open in new location
        (find-file new-file)
        (setq new-buffer (current-buffer))
        (erase-buffer)
        (insert moved-contents)
        (goto-char (point-min))
        (while (re-search-forward "\\(?:href\\|src\\)\\s-*=\\s-*\"\\([^\"]*\\)\"" nil t)
          (let ((old-url (match-string 1))
                (new-url))
            (unless (or (> 11 (length old-url))
                        (string= "javascript:"
                                 (downcase (substring old-url 0 11))))
              (setq new-url (html-move-make-new-url old-url from-dir to-dir))
              (when new-url
                (replace-match new-url t t nil 1)))))
        (save-buffer)
        (html-move-fix-site-backlinks from to-dir from-dir)
        ;; Make backup at current location of "from" file
        (with-current-buffer moved-buffer
          (set-buffer-modified-p t)
          (save-buffer))
        (kill-buffer moved-buffer)
        ;; Delete moved
        (delete-file from))
      (set-buffer new-buffer)
      (goto-char (point-min))
      (lwarn '(html-move) :warning "Moved to %s" new-file)
      )))

(defun html-move-fix-site-backlinks (to-moved-file to-dir from-dir)
  "Fix all links back to TO-MOVED-FILE.
This is called by `html-move-buffer-file' to fix all links back
to the moved file.  TO-MOVED-FILE is the old location of the
moved file. FROM-DIR is the old directory and TO-DIR the target
directory for the move."
  (html-move-fix-all-backlinks to-moved-file (html-site-current-site-dir) to-dir from-dir)
  (when (html-move-fix-page-list to-moved-file to-dir from-dir)
    (message "Page list for site TOC changed. You need to update TOC.")
    (lwarn '(html-move-fix-site-backlinks) :warning "Page list for site TOC changed. You need to update TOC.")
    ))

(defun html-move-fix-all-backlinks (to-moved-file for-dir to-dir from-dir)
  ;;(message "for-dir=%s" for-dir);(sit-for 2)
  (let ((html-files (directory-files                for-dir t ".*\\.html?$"))
        (sub-dirs   (directory-files-and-attributes for-dir t)))
    (dolist (html-file html-files)
      (html-move-fix-backlinks to-moved-file html-file to-dir from-dir))
    (dolist (sub-entry sub-dirs)
      (let* ((sub-dir (car sub-entry))
             (sub-name (file-name-nondirectory sub-dir)))
        (when (and (eq t (car (cdr sub-entry)))
                   (not (string= "." sub-name))
                   (not (string= ".." sub-name)))
          (html-move-fix-all-backlinks to-moved-file sub-dir to-dir from-dir))))))

(defun html-move-fix-backlinks (to-moved-file for-file to-dir from-dir)
  (when (file-exists-p for-file)
    (let ((old-file-buffer (get-file-buffer for-file))
          (buffer (find-file-noselect for-file)))
      (with-current-buffer buffer
        (goto-char (point-min))
        (while
            (re-search-forward
             "\\(?:href\\|src\\)\\s-*=\\s-*\"\\([^#\"]*\\)\\(?:#[^\"]*\\|\\)\""
             nil t)
          (let* ((old-url (match-string 1))
               (old-absolute-url (expand-file-name
                                  old-url
                                  (file-name-directory for-file)))
               new-url)
            (when (string= old-absolute-url to-moved-file)
              (setq new-url (html-move-make-new-url old-url to-dir from-dir))
              ;;(message "new-backlink=%s" new-url);(sit-for 2)
              (replace-match new-url t t nil 1)
              )))
        (save-buffer)
        (unless old-file-buffer
          (kill-this-buffer))))))

(defun html-move-fix-page-list (to-moved-file to-dir from-dir)
  (let ((for-file (html-site-current-page-list))
        some-change)
    (when (file-exists-p for-file)
      (let ((old-file-buffer (get-file-buffer for-file))
            (buffer (find-file-noselect for-file)))
        (with-current-buffer buffer
          (goto-char (point-min))
          (while
              (re-search-forward
               ;;"\\(?:href\\|src\\)\\s-*=\\s-*\"\\([^#\"]*\\)\\(?:#[^\"]*\\|\\)\""
               "\\s-+###\\s-+\\([^#]*?\\)\\(?:#[^#]*\\|\\)[:space:]*$"
               nil t)
            (let* ((old-url (match-string 1))
                   (old-absolute-url (expand-file-name
                                      old-url
                                      (file-name-directory for-file)))
                   new-url)
              (when (string= old-absolute-url to-moved-file)
                (setq new-url (html-move-make-new-url old-url to-dir from-dir))
                ;;(message "new-backlink=%s" new-url);(sit-for 2)
                (replace-match new-url t t nil 1)
                (setq some-change t)
                )))
          (save-buffer)
          (unless old-file-buffer
            (kill-this-buffer)))))
    some-change))

(provide 'html-move)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; html-move.el ends here