home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / HyperActiveFTP / active-hyper.Admin.el next >
Encoding:
Text File  |  1992-04-15  |  5.9 KB  |  216 lines
  1. ;;; active-hyper admininistrative functions
  2.  
  3.  
  4. (setq debug-on-error t)
  5.  
  6. (setq active-hyper-site-regexp "\\(\\w+\\(\\.\\w+\\)*\\.\\(edu\\|net\\|com\\|mil\\|gov\\|arpa\\)\\)")
  7.  
  8. (setq active-hyper-big-file "~/emacs/hyperbole/ActiveListBig.otl")
  9.  
  10. (defun ah:comp-archives-to-wrolo ()
  11.   "With current-buffer a gnus article or vm-format mail message, parse
  12. out the relevant information to create as much of an wrolo.el entry as
  13. possible." 
  14.   (interactive)
  15.   (ah:define-topic)
  16.   (ah:define-reference)
  17.   (ah:define-ftp-site)
  18.   (ftpg-print-hostname))
  19.  
  20. (defun ah:define-reference ()
  21.   (goto-char (point-min))
  22.   (search-forward "From:" (point-max))
  23.   (beginning-of-line nil)
  24.   (let ((start (point))
  25.     (end (progn
  26.            (end-of-line nil)
  27.            (point))))
  28.     (setq ah-reference (buffer-substring start end))))
  29.  
  30. (defun ah:define-topic ()
  31.   (goto-char (point-min))
  32.   (search-forward "Subject" (point-max))
  33.   (let ((start (progn
  34.          (search-forward "] ")
  35.          (point)))
  36.     (end (progn
  37.            (end-of-line nil)
  38.            (point))))
  39.     (setq ah-topic (buffer-substring start end))))
  40.  
  41. ;;; very useful code obtained from Rodney Peck II (rodney@ipl.rpi.edu)
  42.  
  43. ;-----------------------
  44. ;; grab-ftp.el
  45. ;; a thing to find ftp references and make the ftp connect automatically.
  46. ;; (c)1990 Rodney Peck II   rodney@ipl.rpi.edu
  47. ;; 
  48. ;; please mail changes you might make back to me.  I reserve the right
  49. ;; to call this my own, but it will be released to the FSF when it's done.
  50. ;; Image Processing Lab, Rensselaer Polytechnic Institute
  51. ;; $Header: /home/rodney/elisp/RCS/grab-ftp.el,v 1.2 90/02/07 19:41:00 rodney Exp $
  52.  
  53. (defun ah:define-ftp-site ()
  54.   "brannon removed the set-buffer command"
  55.   (interactive)
  56.   (setq ah-ftp-site 
  57.           (save-excursion
  58.             (let ((host (ftpg-find-hostname))
  59.               (number (ftpg-internet-number)))
  60.               (list host number))))
  61.   (setq ah-ftp-site 
  62.     (concat
  63.      "/anonymous@"
  64.      (if (car ah-ftp-site)
  65.          (car ah-ftp-site)
  66.        (if (cdr ah-ftp-site)
  67.            (cdr ah-ftp-site)
  68.          ""))
  69.      ":"))
  70.   (setq ah-ftp-file
  71.     (if
  72.         (setq M (progn
  73.               (goto-char (point-min))
  74.               (if (search-forward "Archive-name:" (point-max) nil)
  75.               (next-line 2)
  76.              (progn (goto-char (point-min) (next-line 5))))
  77.               (previous-line 1) (beginning-of-line 1)
  78.               (search-forward "/" (point-max) nil)
  79.               (search-backward " " (point-min) nil)
  80.               (let ((start (point))
  81.                 (end (progn
  82.                    (re-search-forward "\\(/[A-Za-z0-9._]+\\)+"))))
  83.             (buffer-substring start (point)))))
  84.         M
  85.     "")))
  86.   
  87.       
  88.       
  89.     
  90. (defun ftpg-print-hostname ()
  91.   (interactive)
  92.   (message (format "host: %s  number: %s file: %s site: %s" (ftpg-find-hostname) (ftpg-internet-number) ah-ftp-file ah-ftp-site)))
  93.  
  94. (defun ftpg-internet-number ()
  95.   (save-excursion
  96.     (goto-char (point-min))        ; top of buffer
  97.     (if (re-search-forward "\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" 
  98.                (point-max) t) ; match internet
  99.     (progn
  100.       (setq L (point))
  101.       (buffer-substring (match-beginning 1) (match-end 1))))))
  102.  
  103. (defun carmemberp (thing lst)
  104.   (cond ((null lst) nil)
  105.     ((equal (car (car lst)) thing) t)
  106.     (t (member thing (cdr lst)))))
  107.  
  108. ;; cl.el
  109.  
  110. (defun member (item list)
  111.   "Look for ITEM in LIST; return first link in LIST whose car is `eql' to ITEM."
  112.   (let ((ptr list)
  113.         (done nil)
  114.         (result '()))
  115.     (while (not (or done (endp ptr)))
  116.       (cond ((eql item (car ptr))
  117.              (setq done t)
  118.              (setq result ptr)))
  119.       (setq ptr (cdr ptr)))
  120.     result))
  121.  
  122. (defun endp (x)
  123.   "t if X is nil, nil if X is a cons; error otherwise."
  124.   (if (listp x)
  125.       (null x)
  126.     (error "endp received a non-cons, non-null argument `%s'"
  127.        (prin1-to-string x))))
  128.  
  129.  
  130. ;;
  131.  
  132. (defun skip-over-regexp (reg bound)
  133.     (while
  134.     (re-search-forward reg bound t)
  135.       nil)
  136.     (next-line 1))
  137.  
  138. (defvar sigpt nil)  
  139.  
  140. (defvar ftpg-syntax-table
  141.   (let ((ours (standard-syntax-table)))
  142.     (modify-syntax-entry ?- "w" ours)
  143.     ours)
  144.   "the syntax table we use to find hostnames and stuff easier")
  145.     
  146. (defun ftpg-find-hostname ()
  147.   (save-excursion
  148.     (let ((old-syntax (syntax-table))
  149.           (signature-point
  150.      (progn 
  151.        (goto-char (point-min))        ; top of buffer
  152.        (if (re-search-forward "^-- ?$" (point-max) t)
  153.            (point) (point-max)))))
  154.       (set-syntax-table ftpg-syntax-table)
  155.       (setq sigpt signature-point)
  156.       (goto-char (point-min))        ; top of buffer
  157.       (next-line 2) ; brannon
  158.       (let ((hosts) (host) (scores))
  159.         (while 
  160.         (re-search-forward active-hyper-site-regexp         
  161.          signature-point t) ; match hostname
  162.          (setq host
  163.                (downcase (buffer-substring
  164.                   (match-beginning 1) (match-end 1))))
  165.          (if (not (carmemberp host hosts))
  166.              (setq hosts (cons (list host (point))
  167.                        hosts))))
  168.         (set-syntax-table old-syntax)
  169.         (let ((best-score (point-max))
  170.           (best-hostname)
  171.           (score)
  172.           (hostname)
  173.           (position))
  174.           (while hosts
  175.         (setq host (car hosts))
  176.         (setq hosts (cdr hosts))
  177.         (setq hostname (car host))
  178.         (setq position (car (cdr host)))
  179.         (goto-char position)
  180.         (setq score (- position 
  181.                    (if (re-search-backward
  182.                     "ftp\\|on\\|from\\|via\\|archive-site"
  183.                     (point-min) t)
  184.                    (point) (point-min))))
  185.         (if (< score best-score)
  186.             (progn (setq best-score score)
  187.                (setq best-hostname hostname))))
  188.           best-hostname)))))
  189.  
  190. (defun ftpg-connect-host ()
  191.   (interactive)
  192.   (process-send-string "shell" 
  193.                (format "ftp %s\n" (ftpg-find-hostname) hostname)))
  194.  
  195.  
  196. ;;; quasi hyper-makefile
  197.  
  198. (setq active-hyper-manifest
  199.       '(".dired" ".hypb" "active-hyper.Admin.el" 
  200.     "active-hyper.Changelog" "active-hyper.Install.el"
  201.     "active-hyper.Makefile" "active-hyper.credits"
  202.     "active-hyper.documentation" "active-hyper.el"
  203.     "active-hyper.list.big.otl" "active-hyper.list.frq.otl"
  204.     "active-hyper.main.menu" "active-hyper.to.do"
  205.     "active-hyper.usenet"))
  206.  
  207. (setq ah-dest-dir "/anonymous@klotho.cs.caltech.edu:/pub/")
  208.  
  209. (defun remote-install ()
  210.   (interactive)
  211.   (mapcar 'copy-to ah-for-remote-install))
  212.  
  213. (defun copy-to (M)
  214.   (copy-file M (concat active-hyper-manifest M)))
  215.     
  216.