302 |
;;; Filename manipulation |
;;; Filename manipulation |
303 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
304 |
|
|
305 |
(defun shadow-parse-fullpath (fullpath) |
(defun shadow-parse-fullname (fullname) |
306 |
"Parse FULLPATH into \(site user path) list. |
"Parse FULLNAME into \(site user path) list. |
307 |
Leave it alone if it already is one. Returns nil if the argument is |
Leave it alone if it already is one. Returns nil if the argument is |
308 |
not a full ange-ftp pathname." |
not a full ange-ftp pathname." |
309 |
(if (listp fullpath) |
(if (listp fullname) |
310 |
fullpath |
fullname |
311 |
(ange-ftp-ftp-name fullpath))) |
(ange-ftp-ftp-name fullname))) |
312 |
|
|
313 |
(defun shadow-parse-path (path) |
(defun shadow-parse-name (name) |
314 |
"Parse any PATH into \(site user path) list. |
"Parse any NAME into \(site user name) list. |
315 |
Argument can be a simple path, full ange-ftp path, or already a hup list." |
Argument can be a simple name, full ange-ftp name, or already a hup list." |
316 |
(or (shadow-parse-fullpath path) |
(or (shadow-parse-fullname name) |
317 |
(list shadow-system-name |
(list shadow-system-name |
318 |
(user-login-name) |
(user-login-name) |
319 |
path))) |
name))) |
320 |
|
|
321 |
(defsubst shadow-make-fullpath (host user path) |
(defsubst shadow-make-fullname (host user name) |
322 |
"Make an ange-ftp style fullpath out of HOST, USER (optional), and PATH. |
"Make an ange-ftp style fullname out of HOST, USER (optional), and NAME. |
323 |
This is probably not as general as it ought to be." |
This is probably not as general as it ought to be." |
324 |
(concat "/" |
(concat "/" |
325 |
(if user (concat user "@")) |
(if user (concat user "@")) |
326 |
host ":" |
host ":" |
327 |
path)) |
name)) |
328 |
|
|
329 |
(defun shadow-replace-path-component (fullpath newpath) |
(defun shadow-replace-name-component (fullname newname) |
330 |
"Return FULLPATH with the pathname component changed to NEWPATH." |
"Return FULLNAME with the name component changed to NEWNAME." |
331 |
(let ((hup (shadow-parse-fullpath fullpath))) |
(let ((hup (shadow-parse-fullname fullname))) |
332 |
(shadow-make-fullpath (nth 0 hup) (nth 1 hup) newpath))) |
(shadow-make-fullname (nth 0 hup) (nth 1 hup) newname))) |
333 |
|
|
334 |
(defun shadow-local-file (file) |
(defun shadow-local-file (file) |
335 |
"If FILE is at this site, remove /user@host part. |
"If FILE is at this site, remove /user@host part. |
336 |
If refers to a different system or a different user on this system, |
If refers to a different system or a different user on this system, |
337 |
return nil." |
return nil." |
338 |
(let ((hup (shadow-parse-fullpath file))) |
(let ((hup (shadow-parse-fullname file))) |
339 |
(cond ((null hup) file) |
(cond ((null hup) file) |
340 |
((and (shadow-site-match (nth 0 hup) shadow-system-name) |
((and (shadow-site-match (nth 0 hup) shadow-system-name) |
341 |
(string-equal (nth 1 hup) (user-login-name))) |
(string-equal (nth 1 hup) (user-login-name))) |
344 |
|
|
345 |
(defun shadow-expand-cluster-in-file-name (file) |
(defun shadow-expand-cluster-in-file-name (file) |
346 |
"If hostname part of FILE is a cluster, expand it to cluster's primary hostname. |
"If hostname part of FILE is a cluster, expand it to cluster's primary hostname. |
347 |
Will return the pathname bare if it is a local file." |
Will return the name bare if it is a local file." |
348 |
(let ((hup (shadow-parse-path file)) |
(let ((hup (shadow-parse-name file)) |
349 |
cluster) |
cluster) |
350 |
(cond ((null hup) file) |
(cond ((null hup) file) |
351 |
((shadow-local-file hup)) |
((shadow-local-file hup)) |
352 |
((shadow-make-fullpath (shadow-site-primary (nth 0 hup)) |
((shadow-make-fullname (shadow-site-primary (nth 0 hup)) |
353 |
(nth 1 hup) |
(nth 1 hup) |
354 |
(nth 2 hup)))))) |
(nth 2 hup)))))) |
355 |
|
|
362 |
Do so by replacing (when possible) home directory with ~, and hostname |
Do so by replacing (when possible) home directory with ~, and hostname |
363 |
with cluster name that includes it. Filename should be absolute and |
with cluster name that includes it. Filename should be absolute and |
364 |
true." |
true." |
365 |
(let* ((hup (shadow-parse-path file)) |
(let* ((hup (shadow-parse-name file)) |
366 |
(homedir (if (shadow-local-file hup) |
(homedir (if (shadow-local-file hup) |
367 |
shadow-homedir |
shadow-homedir |
368 |
(file-name-as-directory |
(file-name-as-directory |
369 |
(nth 2 (shadow-parse-fullpath |
(nth 2 (shadow-parse-fullname |
370 |
(expand-file-name |
(expand-file-name |
371 |
(shadow-make-fullpath |
(shadow-make-fullname |
372 |
(nth 0 hup) (nth 1 hup) "~"))))))) |
(nth 0 hup) (nth 1 hup) "~"))))))) |
373 |
(suffix (shadow-suffix homedir (nth 2 hup))) |
(suffix (shadow-suffix homedir (nth 2 hup))) |
374 |
(cluster (shadow-site-cluster (nth 0 hup)))) |
(cluster (shadow-site-cluster (nth 0 hup)))) |
375 |
(shadow-make-fullpath |
(shadow-make-fullname |
376 |
(if cluster |
(if cluster |
377 |
(shadow-cluster-name cluster) |
(shadow-cluster-name cluster) |
378 |
(nth 0 hup)) |
(nth 0 hup)) |
384 |
(defun shadow-same-site (pattern file) |
(defun shadow-same-site (pattern file) |
385 |
"True if the site of PATTERN and of FILE are on the same site. |
"True if the site of PATTERN and of FILE are on the same site. |
386 |
If usernames are supplied, they must also match exactly. PATTERN and FILE may |
If usernames are supplied, they must also match exactly. PATTERN and FILE may |
387 |
be lists of host, user, path, or ange-ftp pathnames. FILE may also be just a |
be lists of host, user, name, or ange-ftp file names. FILE may also be just a |
388 |
local filename." |
local filename." |
389 |
(let ((pattern-sup (shadow-parse-fullpath pattern)) |
(let ((pattern-sup (shadow-parse-fullname pattern)) |
390 |
(file-sup (shadow-parse-path file))) |
(file-sup (shadow-parse-name file))) |
391 |
(and |
(and |
392 |
(shadow-site-match (nth 0 pattern-sup) (nth 0 file-sup)) |
(shadow-site-match (nth 0 pattern-sup) (nth 0 file-sup)) |
393 |
(or (null (nth 1 pattern-sup)) |
(or (null (nth 1 pattern-sup)) |
395 |
|
|
396 |
(defun shadow-file-match (pattern file &optional regexp) |
(defun shadow-file-match (pattern file &optional regexp) |
397 |
"Return t if PATTERN matches FILE. |
"Return t if PATTERN matches FILE. |
398 |
If REGEXP is supplied and nonnil, the pathname part of the pattern is a regular |
If REGEXP is supplied and non-nil, the file part of the pattern is a regular |
399 |
expression, otherwise it must match exactly. The sites and usernames must |
expression, otherwise it must match exactly. The sites and usernames must |
400 |
match---see shadow-same-site. The pattern must be in full ange-ftp format, but |
match---see shadow-same-site. The pattern must be in full ange-ftp format, but |
401 |
the file can be any valid filename. This function does not do any filename |
the file can be any valid filename. This function does not do any filename |
402 |
expansion or contraction, you must do that yourself first." |
expansion or contraction, you must do that yourself first." |
403 |
(let* ((pattern-sup (shadow-parse-fullpath pattern)) |
(let* ((pattern-sup (shadow-parse-fullname pattern)) |
404 |
(file-sup (shadow-parse-path file))) |
(file-sup (shadow-parse-name file))) |
405 |
(and (shadow-same-site pattern-sup file-sup) |
(and (shadow-same-site pattern-sup file-sup) |
406 |
(if regexp |
(if regexp |
407 |
(string-match (nth 2 pattern-sup) (nth 2 file-sup)) |
(string-match (nth 2 pattern-sup) (nth 2 file-sup)) |
408 |
(string-equal (nth 2 pattern-sup) (nth 2 file-sup)))))) |
(string-equal (nth 2 pattern-sup) (nth 2 file-sup)))))) |
409 |
|
|
410 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
411 |
;;; User-level Commands |
;;; User-level Commands |
412 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
452 |
new version will be copied to each of the other locations. Sites can be |
new version will be copied to each of the other locations. Sites can be |
453 |
specific hostnames, or names of clusters \(see `shadow-define-cluster')." |
specific hostnames, or names of clusters \(see `shadow-define-cluster')." |
454 |
(interactive) |
(interactive) |
455 |
(let* ((hup (shadow-parse-fullpath |
(let* ((hup (shadow-parse-fullname |
456 |
(shadow-contract-file-name (buffer-file-name)))) |
(shadow-contract-file-name (buffer-file-name)))) |
457 |
(path (nth 2 hup)) |
(name (nth 2 hup)) |
458 |
user site group) |
user site group) |
459 |
(while (setq site (shadow-read-site)) |
(while (setq site (shadow-read-site)) |
460 |
(setq user (read-string (format "Username [default %s]: " |
(setq user (read-string (format "Username [default %s]: " |
461 |
(shadow-get-user site))) |
(shadow-get-user site))) |
462 |
path (read-string "Filename: " path)) |
name (read-string "Filename: " name)) |
463 |
(setq group (cons (shadow-make-fullpath site |
(setq group (cons (shadow-make-fullname site |
464 |
(if (string-equal "" user) |
(if (string-equal "" user) |
465 |
(shadow-get-user site) |
(shadow-get-user site) |
466 |
user) |
user) |
467 |
path) |
name) |
468 |
group))) |
group))) |
469 |
(setq shadow-literal-groups (cons group shadow-literal-groups))) |
(setq shadow-literal-groups (cons group shadow-literal-groups))) |
470 |
(shadow-write-info-file)) |
(shadow-write-info-file)) |
483 |
(if (buffer-file-name) |
(if (buffer-file-name) |
484 |
(shadow-regexp-superquote |
(shadow-regexp-superquote |
485 |
(nth 2 |
(nth 2 |
486 |
(shadow-parse-path |
(shadow-parse-name |
487 |
(shadow-contract-file-name |
(shadow-contract-file-name |
488 |
(buffer-file-name)))))))) |
(buffer-file-name)))))))) |
489 |
site sites usernames) |
site sites usernames) |
497 |
(cons (shadow-make-group regexp sites usernames) |
(cons (shadow-make-group regexp sites usernames) |
498 |
shadow-regexp-groups)) |
shadow-regexp-groups)) |
499 |
(shadow-write-info-file))) |
(shadow-write-info-file))) |
500 |
|
|
501 |
(defun shadow-shadows () |
(defun shadow-shadows () |
502 |
;; Mostly for debugging. |
;; Mostly for debugging. |
503 |
"Interactive function to display shadows of a buffer." |
"Interactive function to display shadows of a buffer." |
558 |
be shadowed), list of SITES, and corresponding list of USERNAMES for each |
be shadowed), list of SITES, and corresponding list of USERNAMES for each |
559 |
site." |
site." |
560 |
(if sites |
(if sites |
561 |
(cons (shadow-make-fullpath (car sites) (car usernames) regexp) |
(cons (shadow-make-fullname (car sites) (car usernames) regexp) |
562 |
(shadow-make-group regexp (cdr sites) (cdr usernames))) |
(shadow-make-group regexp (cdr sites) (cdr usernames))) |
563 |
nil)) |
nil)) |
564 |
|
|
619 |
(car groups)))) |
(car groups)))) |
620 |
(append (cond ((equal nonmatching (car groups)) nil) |
(append (cond ((equal nonmatching (car groups)) nil) |
621 |
(regexp |
(regexp |
622 |
(let ((realpath (nth 2 (shadow-parse-fullpath file)))) |
(let ((realname (nth 2 (shadow-parse-fullname file)))) |
623 |
(mapcar |
(mapcar |
624 |
(function |
(function |
625 |
(lambda (x) |
(lambda (x) |
626 |
(shadow-replace-path-component x realpath))) |
(shadow-replace-name-component x realname))) |
627 |
nonmatching))) |
nonmatching))) |
628 |
(t nonmatching)) |
(t nonmatching)) |
629 |
(shadow-shadows-of-1 file (cdr groups) regexp))))) |
(shadow-shadows-of-1 file (cdr groups) regexp))))) |
799 |
; (symbol-function 'symlink-expand-file-name))) |
; (symbol-function 'symlink-expand-file-name))) |
800 |
; (if (not (fboundp 'ange-ftp-ftp-name)) |
; (if (not (fboundp 'ange-ftp-ftp-name)) |
801 |
; (fset 'ange-ftp-ftp-name |
; (fset 'ange-ftp-ftp-name |
802 |
; (symbol-function 'ange-ftp-ftp-path)))) |
; (symbol-function 'ange-ftp-ftp-name)))) |
803 |
|
|
804 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
805 |
;;; Hook us up |
;;; Hook us up |