#!/bin/sh
: ; exec klone $0 "$@"
; The above line finds the klone executable in the $PATH
;(load "debug")
;(kdb t)
; do not rely on autoload, since we are rebuilding it
(load "octal")
(load "defvar")
(load "stack-dump")
(load "statparams")
(load "file-type")
(if (= *machine* 'amiga) (load "grep"))
(defvar klone-update:version 3)
(defun hash-function-default (s &aux
(hash 0)
(l (length s))
(inc (if (< l 8) 1 (logshift l -3)))
(i 0)
)
(while (< i l)
(setq hash (+ (logshift hash 3) (logshift hash -28) (i s)))
(incf i inc)
)
hash
)
;; Klone script to update the AUTOLOAD.DIR in the given dirs on the command
;; line, or in the current dir or in the path if given the argument all
(setq directories (list))
(setq args (subseq *arguments* 1 )) ; exclude command name
; parse switches
(setq Verbose ())
(while (and (setq opt (getn args 0)) (= #\- (getn opt 0)))
(if (= "-v" opt)
(setq Verbose t)
(= "-path" opt)
(setq directories *load-pathname*)
(progn
(? "\
USAGE: klone-update [options] directories
directories are the directory where to update AUTOLOAD.DIR
defaults to current directory.
options can be:
-v verbose
-path all dirs in *load-pathname* are updated
")
(exit 1)
)
)
(delete args 0)
)
(if Verbose
(setq out *standard-output*)
(setq out (open (copy "") :type :string :direction :output))
)
(if
args
(setq directories (+ directories args))
(if (not directories) (setq directories '(".")))
)
(setq old-dir directories)
(setq directories (list))
(dolist (dir old-dir)
(if (seek directories dir) ()
(put directories -1 dir)
))
(setq autoload-comment (regcomp "^[#]"))
(defun process-directories ()
(dolist (dir directories)
(process-directory dir)
))
(defun process-directory (dir &aux
(*current-directory* ".")
)
(if (setq *current-directory* dir)
(progn (print-format out "processing directory %0\n" dir)
(process-current-directory))
(print-format out "directory %0 ignored\n" dir)
)
)
(defun process-subdirectory (subdir)
(print-format out " processing sub-directory %0\n" subdir)
(process-current-directory (+ subdir "/"))
)
(defun process-current-directory (&optional (subdir "") &aux
(files (list))
(subdirs (list))
(grep-output (copy ""))
grep-fd
ftype
fd
patterns
entry
)
;; fills patterns
(if (file-type (+ subdir "AUTOLOAD.PAT"))
(with (fd (open (+ subdir "AUTOLOAD.PAT"))
line ())
(setq patterns (list))
(catch 'EOF (while (setq line (read-line fd))
(if (not (or (regexec autoload-comment line)
(= "" line)
))
(put patterns -1 (regcomp line))
))))
(setq patterns (list (regcomp ".*[.]kl$")))
)
(dolist (entry (if (= "" subdir) (directory)
(map List (lambda (s) (+ subdir s)) (directory subdir))
))
(setq ftype (file-type entry))
(if
(and (= 'file ftype) ; regular file
(catch 'OK
(map ()
(lambda (p) (if (regexec p entry) (throw 'OK t)))
patterns
)
()
))
(put files -1 entry)
(= 'directory ftype) ; subdir
(nconc grep-output (process-subdirectory entry))
))
(nconc grep-output
(process-files
(if (> (length files) 1) files (+ files (list "/dev/null"))))
)
(if (= subdir "") (progn ; only create .DIR in top
(if (/= 0 (wait (system "echo > AUTOLOAD.DIR")))
(? "klone-update error: cannot update AUTOLOAD.DIR in "
*current-directory* "\n"
)
(progn
(system "chmod a+rwx AUTOLOAD.DIR")
(if Verbose (? grep-output))
(klone-update-dir (open grep-output :type :string))
)))
;; else return the output
grep-output
)
)
(defun process-files (l &aux grep-pipe res)
(print-format out " Files: %0\n" l)
(if (= *machine* 'amiga)
(setq res (apply grep (+ '("^[;][;]AUTOLOAD: ") l)))
(progn
(system (+ (list "grep" "^[;][;]AUTOLOAD: ") l)
:output 'grep-pipe
)
(setq res (coerce grep-pipe String))
))
(if Verbose (progn (print-format out " Results:\n%0" res)
(flush out)
))
res
)
(defun klone-update-dir (in)
(setq dir (open "AUTOLOAD.DIR" :direction :output :if-exists :supersede))
(print-format *standard-error* "Updating AUTOLOAD.DIR in %0\n"
*current-directory*
)
(if (not (boundp 'dir)) (progn
(print-format () "Cannot open AUTOLOAD.DIR in %0\n"
*current-directory*
)
(exit)
))
(setq reline (regcomp "^([^:]*):[;][;]AUTOLOAD:[ \t]*([^ \t]+)(.*)$"))
(setq blank-string " ")
(setq entries (coerce (list) Hashtable))
(setq slots (list))
(setq slot-offsets (list))
(catch 'EOF
(while t
(setq line (read-line in))
(if Verbose (print-format out " ==> %0\n" line))
(if (not (regexec reline line))
(print-format *standard-error* "Bad line: %0\n" line)
(progn
(setq symbol (coerce (regsub reline "\\2") Atom))
(if (getn entries symbol)
(print-format *standard-error*
"symbol defined twice: %0 in %1 and %2\n"
symbol
(getn (getn entries symbol) 0)
(regsub reline "\\1")
)
(put entries symbol
(list (regsub reline "\\1")
(regsub reline "\\3")
)))))))
(setq number-of-slots (length entries))
(dohash (symbol line entries)
(setq slot (mod (*:hash (String symbol)) number-of-slots))
(setq l (getn slots slot))
(if l
(put l -1
(list symbol (getn line 0) (getn line 1))
)
(put slots slot
(list (list symbol (getn line 0) (getn line 1)))
))
)
(setq number-of-digits 3)
(setq size 128)
(with (stream (coerce "" Stream))
(with (*print-readably* t)
(write (coerce hash-function-default List) stream)
)
(incf size (length (coerce stream String)))
)
(dotimes (n number-of-slots)
(incf size 3)
(setq slot (getn slots n))
(if slot
(map () (lambda (entry)
(incf size (+ 7
(length (getn entry 0))
(length (getn entry 1))
(length (getn entry 2))
)))
slot
))
)
(incf size (* number-of-slots (+ 1 number-of-digits)))
(setq old-digits number-of-digits)
(while (/= old-digits (setq number-of-digits (length (coerce size String))))
(incf size (* number-of-slots (- number-of-digits old-digits)))
(setq old-digits number-of-digits)
)
;header
(write "#!/usr/local/bin/klone-update\n" dir)
(write "AUTOLOAD\n" dir)
(print-format dir "%0\n" klone-update:version)
(setq file-size-offset (file-position dir))
(write (subseq blank-string 0 number-of-digits) dir)
(write "\n" dir)
(with (*print-readably* t)
(write (coerce hash-function-default List) dir)
)
(print-format dir "\n%0\n%1\n" number-of-slots number-of-digits)
;slot indexes
(setq start-of-slot-indexes (file-position dir))
(setq s (subseq blank-string 0 number-of-digits))
(dotimes (i number-of-slots)
(write s dir)
(write "\n" dir)
)
(setq start-of-slots (file-position dir))
(dotimes (n number-of-slots)
(setq slot (getn slots n))
(put slot-offsets n (file-position dir))
(if slot
(map () (lambda (entry)
(print-format dir "(%0 \"%1\" %2)\n"
(getn entry 0)
(getn entry 1)
(getn entry 2)
))
slot
))
(write "()\n" dir)
)
(file-position dir start-of-slot-indexes 0)
(dotimes (n number-of-slots)
(setq s (coerce (get slot-offsets n) String))
(write (subseq blank-string 0 (- number-of-digits (length s))) dir)
(write s dir)
(write "\n" dir)
)
(file-position dir 0 2)
(setq file-size (file-position dir))
(file-position dir file-size-offset 0)
(setq s (coerce file-size String))
(write (subseq blank-string 0 (- number-of-digits (length s))) dir)
(write s dir)
(flush dir)
(close dir)
)
(process-directories)
;;=============================================================================
;;################### SMARTDOC ################################################;;=============================================================================
;#!/usr/local/bin/klone
;(load "debug")
;(kdb t)
; do not rely on autoload, since we are rebuilding it
;(load "octal")
;(load "stack-dump")
;(load "statparams")
;(load "file-type")
;; Klone script to update the AUTODOC.DIR in the given dirs on the command
;; line, or in the current dir or in the path if given the argument all
; (setq args (subseq *arguments* 1 )) ; exclude command name
; ; parse switches
; (setq Verbose ())
; (while (and (setq opt (getn args 0)) (= #\- (getn opt 0)))
; (if (= "-v" opt)
; (setq Verbose t)
;
; (progn
; (? "\
; USAGE: klone-update [options] directories
; directories are the directory where to update AUTODOC.DIR
; defaults to current directory, or all dirs in path if name is all
; options can be:
; -v verbose
; ")
; (exit 1)
; )
; )
; (delete args 0)
; )
;
(setq autodoc-comment (regcomp "^[#]"))
(defun process-current-directory (&optional (subdir "") &aux
(files (list))
(subdirs (list))
(grep-output (copy ""))
grep-fd
ftype
fd
patterns
entry
)
;; fills patterns
(if (file-type (+ subdir "AUTODOC.PAT"))
(with (fd (open (+ subdir "AUTODOC.PAT"))
line ())
(setq patterns (list))
(catch 'EOF (while (setq line (read-line fd))
(if (not (or (regexec autodoc-comment line)
(= "" line)
))
(put patterns -1 (regcomp line))
))))
(setq patterns (list (regcomp ".*[.]kl$")))
)
(dolist (entry (if (= "" subdir) (directory)
(map List (lambda (s) (+ subdir s)) (directory subdir))
))
(setq ftype (file-type entry))
(if
(and (= 'file ftype) ; regular file
(catch 'OK
(map ()
(lambda (p) (if (regexec p entry) (throw 'OK t)))
patterns
)
()
))
(put files -1 entry)
(= 'directory ftype) ; subdir
(nconc grep-output (process-subdirectory entry))
))
(nconc grep-output
(process-files
(if (> (length files) 1) files (+ files (list "/dev/null"))))
)
(if (= subdir "") (progn ; only create .DIR in top
(if (/= 0 (wait (system "echo > AUTODOC.DIR")))
(? "klone-update error: cannot update AUTODOC.DIR in "
*current-directory* "\n"
)
(progn
(system "chmod a+rwx AUTODOC.DIR")
;; (if Verbose (? grep-output))
(klone-update-dir (open grep-output :type :string))
)))
;; else return the output
grep-output
)
)
(defun process-files (l &aux grep-pipe res)
(print-format out " Files: %0\n" l)
(if (= *machine* 'amiga)
(setq res (apply grep (+ '("^[;][;]AUTOLOAD: ") l)))
(progn
(system (+ (list "grep" "^[;][;]AUTODOC: ") l)
:output 'grep-pipe
)
(setq res (coerce grep-pipe String))
))
;; (if Verbose (progn (print-format out " Results:\n%0" res)
;; (flush out)
;; ))
res
)
(defun strip-string (s &aux re
)
(if (regexec {regcomp "^[\"].*[\"]$"} s)
(non-nil-or (trap-error 'ALL (read (open s :type :string)))
s
)
(regexec (setq re {regcomp "^[\"](.*[^\"])$"}) s)
(regsub re 1)
(regexec (setq re {regcomp "^([^\"].*)[\"]$"}) s)
(regsub re 1)
s
)
)
(defun klone-update-dir (in &aux
the-reline
)
(setq dir (open "AUTODOC.DIR" :direction :output :if-exists :supersede))
(print-format *standard-error* "Updating AUTODOC.DIR in %0\n"
*current-directory*
)
(if (not (boundp 'dir)) (progn
(print-format () "Cannot open AUTODOC.DIR in %0\n"
*current-directory*
)
(exit)
))
(setq reline (regcomp
"^([^:]*):[;][;]AUTODOC:[ \t]*[\"]?([^ \t\"]+)[\"]?[ \t]*(.*)$"))
(setq reline-quoted (regcomp
"^([^:]*):[;][;]AUTODOC:[ \t]*[\"]([^\"]+)[\"][ \t]*(.*)$"))
(setq blank-string " ")
(setq entries (coerce (list) Hashtable))
(setq slots (list))
(setq slot-offsets (list))
(catch 'EOF
(while t
(setq line (read-line in))
(if Verbose (print-format out " ==> %0\n" line))
(if
(not (regexec reline line))
(print-format *standard-error* "Bad line: %0\n" line)
(progn
(if (regexec reline-quoted line)
(setq the-reline reline-quoted)
(setq the-reline reline)
)
(setq symbol (regsub the-reline "\\2"))
(if
(getn entries symbol)
(put (getn entries symbol) -1
(list (strip-string (regsub the-reline "\\1"))
(strip-string (regsub the-reline "\\3"))
)
)
(put entries symbol
(list (list (strip-string (regsub the-reline "\\1"))
(strip-string (regsub the-reline "\\3")))
)
))
))))
(setq number-of-slots (length entries))
(dohash (symbol lines entries)
(setq slot (mod (*:hash (String symbol)) number-of-slots))
(setq l (getn slots slot))
(if (not l)
(put slots slot (setq l (list)))
)
(dolist (line lines)
(put l -1
(list symbol (getn line 0) (getn line 1))
))
)
(setq number-of-digits 3)
(setq size 128)
(with (stream (coerce "" Stream))
(with (*print-readably* t)
(write (coerce hash-function-default List) stream)
)
(incf size (length (coerce stream String)))
)
(dotimes (n number-of-slots)
(incf size 3)
(setq slot (getn slots n))
(if slot
(map () (lambda (entry)
(incf size (+ 7
(length (getn entry 0))
(length (getn entry 1))
(length (getn entry 2))
)))
slot
))
)
(incf size (* number-of-slots (+ 1 number-of-digits)))
(setq old-digits number-of-digits)
(while (/= old-digits (setq number-of-digits (length (coerce size String))))
(incf size (* number-of-slots (- number-of-digits old-digits)))
(setq old-digits number-of-digits)
)
;header
(write "#!/usr/local/bin/klone-update\n" dir)
(write "AUTODOC\n" dir)
(print-format dir "%0\n" klone-update:version)
(setq file-size-offset (file-position dir))
(write (subseq blank-string 0 number-of-digits) dir)
(write "\n" dir)
(with (*print-readably* t)
(write (coerce hash-function-default List) dir)
)
(print-format dir "\n%0\n%1\n" number-of-slots number-of-digits)
;slot indexes
(setq start-of-slot-indexes (file-position dir))
(setq s (subseq blank-string 0 number-of-digits))
(dotimes (i number-of-slots)
(write s dir)
(write "\n" dir)
)
(setq start-of-slots (file-position dir))
(dotimes (n number-of-slots)
(setq slot (getn slots n))
(put slot-offsets n (file-position dir))
(if slot
(map () (lambda (entry)
(print-format dir "(%r0 %r1 %r2)\n"
(getn entry 0)
(getn entry 1)
(getn entry 2)
))
slot
))
(write "()\n" dir)
)
(file-position dir start-of-slot-indexes 0)
(dotimes (n number-of-slots)
(setq s (coerce (get slot-offsets n) String))
(write (subseq blank-string 0 (- number-of-digits (length s))) dir)
(write s dir)
(write "\n" dir)
)
(file-position dir 0 2)
(setq file-size (file-position dir))
(file-position dir file-size-offset 0)
(setq s (coerce file-size String))
(write (subseq blank-string 0 (- number-of-digits (length s))) dir)
(write s dir)
(flush dir)
(close dir)
)
(process-directories)
;;; EMACS MODES
;;; Local Variables: ***
;;; mode:lisp ***
;;; End: ***
syntax highlighted by Code2HTML, v. 0.9.1