nxhtml/nxhtml/html-upl.el

   1 ;;; html-upl.el --- Uploading of web sites
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: Mon Mar 06 19:09:19 2006
   5 (defconst html-upl:version "0.3") ;; Version:
   6 ;; Last-Updated: 2008-03-22T01:23:01+0100 Sat
   7 ;; Keywords:
   8 ;; Compatibility:
   9 ;;
  10 ;; Features that might be required by this library:
  11 ;;
  12 ;;   `cl', `html-site', `html-upl', `mail-prsvr', `mm-util', `timer',
  13 ;;   `url-c', `url-parse', `url-vars'.
  14 ;;
  15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16 ;;
  17 ;;; Commentary:
  18 ;;
  19 ;;
  20 ;;
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 ;;
  23 ;;; Change log:
  24 ;;
  25 ;;
  26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27 ;;
  28 ;; This program is free software; you can redistribute it and/or modify
  29 ;; it under the terms of the GNU General Public License as published by
  30 ;; the Free Software Foundation; either version 2, or (at your option)
  31 ;; any later version.
  32 ;;
  33 ;; This program is distributed in the hope that it will be useful,
  34 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  35 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  36 ;; GNU General Public License for more details.
  37 ;;
  38 ;; You should have received a copy of the GNU General Public License
  39 ;; along with this program; see the file COPYING.  If not, write to the
  40 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  41 ;; Boston, MA 02111-1307, USA.
  42 ;;
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44 ;;
  45 ;;; Code:
  46 (eval-when-compile (add-to-list 'load-path default-directory load-path))
  47 (eval-when-compile (require 'html-site nil t))
  48
  49 ;;;###autoload
  50 (defgroup html-upl nil
  51   "Customization group for html-upl."
  52   :group 'nxhtml)
  53
  54 (defcustom html-upl-dir
  55   (file-name-as-directory
  56    (expand-file-name
  57     "html-upl"
  58     (file-name-directory
  59      (if load-file-name load-file-name buffer-file-name))))
  60
  61   "Directory where the tools needed are located.
  62 The tools for html-upl includes:
  63
  64 - ftpsync.pl
  65 "
  66   :type 'directory
  67   :group 'html-upl)
  68
  69 (defun html-upl-browse-remote ()
  70   (interactive)
  71   (let ((url (html-site-local-to-web html-site-current
  72                                      ;;buffer-file-name
  73                                      (html-site-buffer-or-dired-file-name)
  74                                      nil)))
  75     (browse-url url)))
  76 (defun html-upl-browse-remote-with-toc ()
  77   (interactive)
  78   (let ((url (html-site-local-to-web html-site-current
  79                                      ;;buffer-file-name
  80                                      (html-site-buffer-or-dired-file-name)
  81                                      t)))
  82     (browse-url url)))
  83 (defun html-upl-browse-remote-frames ()
  84   (interactive)
  85   (let ((url (html-site-local-to-web (html-site-current-frames-file)
  86                                      ;;buffer-file-name
  87                                      (html-site-buffer-or-dired-file-name)
  88                                      nil)))
  89     (browse-url url)))
  90
  91 ;;;###autoload
  92 (defun html-upl-upload-site-with-toc ()
  93   (interactive)
  94   (html-upl-upload-site1 t))
  95
  96 ;;;###autoload
  97 (defun html-upl-upload-site ()
  98   (interactive)
  99   (html-upl-upload-site1 nil))
 100 (defun html-upl-upload-site1(with-toc)
 101   (html-site-current-ensure-site-defined)
 102   (html-upl-ensure-site-has-host)
 103   (let ((local-dir (if with-toc
 104                        (html-site-current-merge-dir)
 105                      (html-site-current-site-dir)))
 106         (ftp-host (html-site-current-ftp-host))
 107         (ftp-user (html-site-current-ftp-user))
 108         (ftp-pw (html-site-current-ftp-password))
 109         (ftp-dir (if with-toc
 110                      (html-site-current-ftp-wtoc-dir)
 111                    (html-site-current-ftp-dir)))
 112         (ftpsync-pl (expand-file-name "ftpsync.pl" html-upl-dir))
 113         )
 114     (unless (< 0 (length ftp-host))
 115       (error "Ftp host not defined"))
 116     (unless (< 0 (length ftp-user))
 117       (error "Ftp user not defined"))
 118     (unless (< 0 (length ftp-dir))
 119       (if with-toc
 120           (error "Ftp remote directory for pages with TOC not defined")
 121         (error "Ftp remote directory not defined")))
 122     (unless (< 0 (length ftp-pw))
 123       (setq ftp-pw (html-site-get-ftp-pw)))
 124     (let* (
 125            (buffer (noshell-procbuf-setup "subprocess for upload"))
 126            (remote-url (concat "ftp://" ftp-user ":" ftp-pw "@" ftp-host ftp-dir))
 127            (opt (list
 128                  "-v"
 129                  "-p"
 130                  local-dir
 131                  remote-url)))
 132       (apply 'noshell-procbuf-run
 133              buffer
 134              "perl" "-w"
 135              ftpsync-pl
 136              opt
 137              ))))
 138
 139 (defun html-upl-ensure-site-has-host ()
 140   (let ((host (html-site-current-ftp-host)))
 141     (unless (and host (< 0 (length host)))
 142       (error "Site %s has no ftp host defined" html-site-current))))
 143
 144 ;;;###autoload
 145 (defun html-upl-remote-dired (dirname)
 146   "Start dired for remote directory or its parent/ancestor."
 147   (interactive (list
 148                 (read-directory-name "Local directory: " nil nil t)))
 149   (html-site-current-ensure-file-in-site dirname)
 150   (html-upl-ensure-site-has-host)
 151   (let* ((local-dir dirname)
 152          (remote-dir (html-site-current-local-to-remote local-dir nil))
 153          to-parent
 154          res
 155          msg)
 156     (while (not res)
 157       (condition-case err
 158           (progn
 159             (dired remote-dir)
 160             (setq res t))
 161         (error ;;(lwarn 't :warning "err=%s" err)
 162                (setq msg (error-message-string err))))
 163       ;; It does not look like we always get an error. Check where we are:
 164       (when res
 165         (unless (string= default-directory remote-dir)
 166           (setq res nil)
 167           (setq msg "")))
 168       (unless res
 169         ;; 450  Requested file action not taken File unavailable (e.g. file busy).
 170         ;; 550  Requested action not taken File unavailable (e.g. file not found, no access).
 171         (if (or (string= msg "")
 172                 (save-match-data (string-match " \\(?:550\\|450\\) " msg)))
 173             (progn
 174               (if (not to-parent)
 175                   (setq to-parent (concat
 176                                    (file-name-nondirectory remote-dir)
 177                                    "/.."))
 178                 (setq to-parent (concat
 179                                  (file-name-nondirectory remote-dir)
 180                                  "/"
 181                                  to-parent "/..")))
 182               ;;(setq local-dir (directory-file-name (file-name-directory (directory-file-name local-dir))))
 183               ;;(html-site-current-ensure-file-in-site local-dir)
 184               ;;(setq remote-dir (html-site-current-local-to-remote local-dir nil))
 185               (setq remote-dir (directory-file-name (file-name-directory remote-dir)))
 186               )
 187           (setq res msg))))
 188     (if (stringp res)
 189        (error "%s" msg)
 190       (when to-parent
 191         (message "Remote dir not found, showing ancestor %s" to-parent)))))
 192
 193 ;;;###autoload
 194 (defun html-upl-upload-file (filename)
 195   "Upload a single file in a site.
 196 For the definition of a site see `html-site-current'."
 197   (interactive (list
 198                 (let ((use-dialog-box nil)
 199                       (f (file-relative-name
 200                           ;;(if (derived-mode-p 'dired-mode) (dired-get-file-for-visit) buffer-file-name)
 201                           (html-site-buffer-or-dired-file-name)
 202                           )))
 203                   (read-file-name "File: " nil nil t f))
 204                 ))
 205   (html-site-current-ensure-file-in-site filename)
 206   (html-upl-ensure-site-has-host)
 207   (let* ((buffer (get-file-buffer filename))
 208          (remote-file (html-site-current-local-to-remote filename nil))
 209          (remote-buffer (get-file-buffer remote-file))
 210          (local-file filename))
 211     (when (or (not buffer-file-name)
 212               (not (buffer-modified-p buffer))
 213               (and
 214                (y-or-n-p (format "Buffer %s is modified. Save buffer and copy? "
 215                                 (buffer-name buffer)))
 216                (with-current-buffer buffer
 217                  (save-buffer)
 218                  (not (buffer-modified-p)))))
 219       (when (= ?~ (string-to-char local-file))
 220         (setq local-file (expand-file-name local-file)))
 221       (when (and (fboundp 'w32-short-file-name)
 222                  (string-match " " local-file))
 223         (setq local-file (w32-short-file-name local-file)))
 224       (copy-file local-file
 225                  ;;(html-site-current-local-to-remote filename nil)
 226                  remote-file
 227                  0)
 228       (when remote-buffer
 229         (with-current-buffer remote-buffer
 230           (revert-buffer nil t t)))
 231       (message "Upload ready")
 232       )))
 233
 234 ;;;###autoload
 235 (defun html-upl-edit-remote-file ()
 236   (interactive)
 237   (html-upl-edit-remote-file1 nil))
 238
 239 ;;;###autoload
 240 (defun html-upl-edit-remote-file-with-toc ()
 241   (interactive)
 242   (html-upl-edit-remote-file1 t))
 243
 244 (defun html-upl-edit-remote-file1(with-toc)
 245   (html-site-current-ensure-buffer-in-site)
 246   (html-upl-ensure-site-has-host)
 247   (let* ((remote-root (concat "/ftp:"
 248                               (html-site-current-ftp-user)
 249                               "@" (html-site-current-ftp-host)
 250                               ":"
 251                               (if with-toc
 252                                   (html-site-current-ftp-wtoc-dir)
 253                                 (html-site-current-ftp-dir))))
 254 ;;          (remote-file (html-site-path-in-mirror (html-site-current-site-dir)
 255 ;;                                                 buffer-file-name
 256 ;;                                                 remote-root))
 257          (remote-file (html-site-current-local-to-remote buffer-file-name nil))
 258          )
 259     (find-file remote-file)))
 260
 261 ;;;###autoload
 262 (defun html-upl-ediff-file (filename)
 263   "Run ediff on local and remote file.
 264 FILENAME could be either the remote or the local file."
 265   ;;(interactive "fFile (local or remote): ")
 266   (interactive (list
 267                 (or (html-site-buffer-or-dired-file-name)
 268                     (read-file-name "File: "))))
 269   (html-upl-ensure-site-has-host)
 270   (let* ((is-local (html-site-file-is-local filename))
 271          remote-name
 272          local-name)
 273     (if is-local
 274         (progn
 275           (html-site-current-ensure-file-in-site filename)
 276           (setq remote-name (html-site-current-local-to-remote filename nil))
 277           (setq local-name filename))
 278       (setq local-name (html-site-current-remote-to-local filename nil))
 279       (html-site-current-ensure-file-in-site local-name)
 280       (setq remote-name filename))
 281     (let ((local-buf (find-file local-name))
 282           (remote-buf (find-file remote-name)))
 283       (ediff-buffers local-buf remote-buf))))
 284
 285 ;;(defun html-site-buffer-or-dired-file-name ()
 286 ;; (defun html-upl-ediff-buffer ()
 287 ;;   "Run ediff on local and remote buffer file.
 288 ;; The current buffer must contain either the local or the remote file."
 289 ;;   (interactive)
 290 ;;   (html-upl-ediff-file (buffer-file-name)))
 291
 292 (provide 'html-upl)
 293 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 294 ;;; html-upl.el ends here
 295
 296 ;; (defun html-site-local-to-remote-path (local-file protocol with-toc)
 297 ;;   (let ((remote-dir (if (eq protocol 'ftp)
 298 ;;                         (if with-toc
 299 ;;                             (html-site-current-ftp-wtoc-dir)
 300 ;;                           (html-site-current-ftp-dir))
 301 ;;                       (if with-toc
 302 ;;                           (html-site-current-web-wtoc-dir)
 303 ;;                         (html-site-current-web-dir)))))
 304 ;;     (html-site-path-in-mirror
 305 ;;      (html-site-current-site-dir) local-file remote-dir)))
 306
 307 ;; (defun html-site-local-to-web (local-file with-toc)
 308 ;;   (let ((web-file (html-site-local-to-remote-path local-file 'http with-toc))
 309 ;;         (web-host (html-site-current-web-host)))
 310 ;;     (save-match-data
 311 ;;       (unless (string-match "^https?://" web-host)
 312 ;;         (setq web-host (concat "http://" web-host))))
 313 ;;     (when (string= "/" (substring web-host -1))
 314 ;;       (setq web-host (substring web-host 0 -1)))
 315 ;;     (concat web-host web-file)
 316 ;;     ))
 317 ;;
 318 ;;; Use tramp-tramp-file-p instead:
 319 ;; (defun html-upl-file-name-is-local (file-name)
 320 ;;   "Return nil unless FILE-NAME is a Tramp file name."
 321 ;;   (save-match-data
 322 ;;     (not (string-match "^/[a-z]+:" file-name))))
 323
 324 ;; (defun html-upl-remote-to-local (remote-file)
 325 ;;   (let ((remote-site-dir (html-site-current-web-dir)))
 326 ;;     (unless (html-site-dir-contains remote-site-dir remote-file)
 327 ;;       (error "")))
 328 ;;   )
 329