1 ;;; html-upl.el --- Uploading of web sites
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
10 ;; Features that might be required by this library:
12 ;; `cl', `html-site', `html-upl', `mail-prsvr', `mm-util', `timer',
13 ;; `url-c', `url-parse', `url-vars'.
15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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)
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.
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.
43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
46 (eval-when-compile (add-to-list 'load-path default-directory load-path))
47 (eval-when-compile (require 'html-site nil t))
50 (defgroup html-upl nil
51 "Customization group for html-upl."
54 (defcustom html-upl-dir
55 (file-name-as-directory
59 (if load-file-name load-file-name buffer-file-name))))
61 "Directory where the tools needed are located.
62 The tools for html-upl includes:
69 (defun html-upl-browse-remote ()
71 (let ((url (html-site-local-to-web html-site-current
73 (html-site-buffer-or-dired-file-name)
76 (defun html-upl-browse-remote-with-toc ()
78 (let ((url (html-site-local-to-web html-site-current
80 (html-site-buffer-or-dired-file-name)
83 (defun html-upl-browse-remote-frames ()
85 (let ((url (html-site-local-to-web (html-site-current-frames-file)
87 (html-site-buffer-or-dired-file-name)
92 (defun html-upl-upload-site-with-toc ()
94 (html-upl-upload-site1 t))
97 (defun html-upl-upload-site ()
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))
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))
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)))
125 (buffer (noshell-procbuf-setup "subprocess for upload"))
126 (remote-url (concat "ftp://" ftp-user ":" ftp-pw "@" ftp-host ftp-dir))
132 (apply 'noshell-procbuf-run
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))))
145 (defun html-upl-remote-dired (dirname)
146 "Start dired for remote directory or its parent/ancestor."
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))
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:
165 (unless (string= default-directory remote-dir)
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)))
175 (setq to-parent (concat
176 (file-name-nondirectory remote-dir)
178 (setq to-parent (concat
179 (file-name-nondirectory remote-dir)
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)))
191 (message "Remote dir not found, showing ancestor %s" to-parent)))))
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'."
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)
203 (read-file-name "File: " nil nil t f))
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))
214 (y-or-n-p (format "Buffer %s is modified. Save buffer and copy? "
215 (buffer-name buffer)))
216 (with-current-buffer 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)
229 (with-current-buffer remote-buffer
230 (revert-buffer nil t t)))
231 (message "Upload ready")
235 (defun html-upl-edit-remote-file ()
237 (html-upl-edit-remote-file1 nil))
240 (defun html-upl-edit-remote-file-with-toc ()
242 (html-upl-edit-remote-file1 t))
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)
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)
257 (remote-file (html-site-current-local-to-remote buffer-file-name nil))
259 (find-file remote-file)))
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): ")
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))
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))))
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."
290 ;; (html-upl-ediff-file (buffer-file-name)))
293 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
294 ;;; html-upl.el ends here
296 ;; (defun html-site-local-to-remote-path (local-file protocol with-toc)
297 ;; (let ((remote-dir (if (eq protocol 'ftp)
299 ;; (html-site-current-ftp-wtoc-dir)
300 ;; (html-site-current-ftp-dir))
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)))
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)))
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)
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."
322 ;; (not (string-match "^/[a-z]+:" file-name))))
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)