archive/share/trash/fileop.lisp

   1 ;;; -*- Mode:LISP; Package:MACSYMA -*-
   2
   3 ;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
   4
   5 (macsyma-module fileop)
   6
   7 ;;; Some simple primitives for looking at files and directories from
   8 ;;; Macsyma.  Printf prints a file; Listf lists a user's files;
   9 ;;; Qlistf lists only the names of the files.
  10
  11 (comment Macsyma user functions)
  12
  13 (DEFMSPEC $printfile (file) (SETQ file (CDR file))
  14        (setq file (open (filestrip file)))
  15        (princ "Printing file ")
  16        (fileprint (truename file))
  17        (terpri)
  18        (do ((in (tyi file -1) (tyi file -1)))
  19            ((= in -1) (close file) '$done)
  20            (declare (fixnum in))
  21            (cond ((= in 12.) (princ "^L"))      ;Otherwise Lisp does randomness.
  22                  ((= in 3))                     ;Don't confuse lusers.
  23                  (t (tyo in)))))
  24
  25 (DEFMSPEC $listfiles (dir) (SETQ dir (CDR dir))
  26        (princ "/
  27 File directory listing./
  28 ")
  29        (mapc 'fileline
  30              (dirsorted dir '(credate link characters undumped pack)))
  31        (terpri))
  32
  33 (DEFMSPEC $qlistfiles (dir) (SETQ dir (CDR dir))
  34        (princ "Quick listing./
  35 ")
  36        (mapc '(lambda (x) (princ (cadar x))
  37                       (princ '/ )
  38                       (princ (caddar x))
  39                       (terpri))
  40              (dirsorted dir nil))
  41        '$done)
  42
  43 (DEFMSPEC $filelist (dir) (SETQ dir (CDR dir))
  44   (cons '(mlist simp)
  45         (mapcar '(lambda (x) (dollarify (list (cadar x) (caddar x))))
  46                 (dirsorted dir nil))))
  47
  48 (DEFMSPEC $filelength (file) (SETQ file (CDR file))
  49   (filelength (filestrip file)))
  50 \f
  51 (comment The internal functions)
  52
  53 ;; Tries to find the user's files: if he uses a multiple-user directory,
  54 ;; his login name is assumed to be the first filename.
  55 (defun real-directory (dir)
  56        (setq dir (car (mergef (list (fullstrip dir)) ())))
  57        (list (cond ((and (eq (car dir) 'dsk)
  58                          (memq (cadr dir) '(users users1 sdrc jonpoe plasma
  59                                             kad ucb lrc lrc1 bellab ball)))
  60                     (list dir (status userid) '*))
  61                    (t (list dir '* '*)))))
  62
  63 ;; Fileline prints the line for each file.
  64 (defun fileline (spec)
  65        ;; spec: (((dsk macrak) rpart 345) credate (...) characters 234235)
  66        (fileprint (car spec))
  67        (cond ((get spec 'link) (linkprint (get spec 'link)))
  68              (t (tabover 30.)
  69                 (dateprint (get spec 'credate))
  70                 (princ " L=")
  71                 (princ (get spec 'characters))
  72                 (princ " chars.")
  73                 (and (get spec 'undumped) (princ '/!))
  74                 (and (equal 13. (get spec 'pack)) (princ " (secondary)"))))
  75        (terpri))
  76
  77 ;; Linkprint handles links:
  78 ;; [MYFILE,1,DSK,LUSER] --saved on tape #177
  79 ;; [MYFILE,34,DSK,LUSER] --linked to file [HISFLE,BIG,DSK,SHARE]
  80 (defun linkprint (linkname)
  81        (cond ((and (eq (cadar linkname) 'backup)  ;((dsk backup) tape ...)
  82                    (eq (cadr linkname) 'tape))
  83               (princ "--saved on tape #")
  84               (princ (caddr linkname)))
  85              (t (princ "--linked to file ")
  86                 (fileprint linkname))))
  87
  88 ;; Prints date as 7/23/80
  89 (defun dateprint (date)                   ;(year month day)
  90        (princ (cadr date))
  91        (princ '//)
  92        (princ (caddr date))
  93        (princ '//)
  94        (princ (car date)))
  95
  96 ;; Returns a Directory in the standard order.
  97 (defun dirsorted (dir specs)
  98        (cond ((sort (sort (directory (real-directory dir) specs)
  99                           '(lambda (x y) (alphalessp (caddar x) (caddar y))))  ;fn2
 100                     '(lambda (x y) (alphalessp (cadar x) (cadar y))))) ;fn1
 101              (t (merror "No files found")
 102                 )))
 103
 104 ;; Tabs to column n
 105 (defun tabover (n) (do ((i (- n (charpos t) 1) (1- i)))
 106                        ((< i 0))
 107                        (tyo 32.)))
 108 \f
 109 ;;; FILES: A library for doing fancier file manipulation from Macsyma
 110
 111 (DECLARE (*EXPR FILESTRIP DOLLARIFY))
 112
 113 ;;; (FILEFORM <file> <function-name>)
 114 ;;;  <file> should be either ((MLIST ...) <fn1> <fn2> ...)
 115 ;;;         or |& ... filename ... | or it will be an error
 116 ;;;  <function-name> is the name of the function to cite if an error
 117 ;;;         is signalled.
 118 ;;; If the function does not err out, it will return a lisp filespec.
 119 ;;; in Macsyma FILESTRIP form.
 120
 121 (DEFUN FILEFORM (X FUN)
 122        (COND ((AND ($LISTP X)
 123                    (APPLY 'AND (MAPCAR 'ATOM (CDR X))))
 124               (FILESTRIP (CDR X)))
 125              (T
 126               (MERROR "~M got a bad file specification. Try [fn1,fn2,dev,dir]."
 127                      FUN))))
 128
 129 ;;; RENAMEFILE(oldname,newname);
 130 ;;; A Macsyma FSUBR - works only renaming files in the same directory.
 131 ;;; Accepts exactly 2 Macsyma-style filespecs.
 132
 133 (DEFMSPEC $RENAMEFILE (ARG-LIST)
 134   (SETQ ARG-LIST (CDR ARG-LIST))
 135   (COND ((NOT (= (LENGTH ARG-LIST) 2.))
 136          (MERROR
 137           "Syntax is RENAMEFILE(oldname,newname); - Wrong number of args")))
 138   (LET ((FILE1 (FILEFORM (CAR ARG-LIST)  'RENAMEFILE))
 139         (FILE2 (FILEFORM (CADR ARG-LIST) 'RENAMEFILE)))
 140     (SETQ FILE2 (MERGEF (NCONS (CDDR FILE1)) FILE2))
 141     (COND ((NOT (PROBEF FILE1))
 142            (MERROR "~M Can't rename a non-existent file!" FILE1)))
 143     (COND ((PROBEF FILE2)
 144            (MERROR "~M Can't rename to an already existing file!"
 145                    (APPEND (CDR FILE2) (CAR FILE2)))))
 146     (LET ((NEWFILE (RENAMEF FILE1 FILE2)))
 147       (DEFAULTF NEWFILE)
 148       ($FILEDEFAULTS))))
 149 \f