Commit 16f7310d authored by Pascal J. Bourguignon's avatar Pascal J. Bourguignon

Merged.

script:   Corrected arguments passed to uname shell command.
manifest: Improved print-bug-report-info (added distribution and uname -a)
          Exported version function for parsed lisp-implementation-version.
parents 03a645cc de18476e
......@@ -144,6 +144,10 @@ License:
;; utility:
"LIST-SYMBOLS" "LIST-ALL-SYMBOLS" "LIST-EXTERNAL-SYMBOLS"
"COPY-PACKAGE"
"STRING-PREPARE-TOKEN"
"UNINTERNED-PREPARE-TOKEN"
"KEYWORD-PREPARE-TOKEN"
"SEXP-FOR-PACKAGE"
;; debugging help:
"CRACK-OPEN-PACKAGE"
;; Obsolete: define-package
......@@ -733,5 +737,85 @@ DO: Declares a package.
(defpackage ,name ,@defpack-args)
(in-package ,name))))
(defun string-prepare-token (kind name)
(declare (ignore kind))
(string name))
(defun uninterned-prepare-token (kind name)
(declare (ignore kind))
(make-symbol (string name)))
(defun keyword-prepare-token (kind name)
(declare (ignore kind))
(intern (string name) (load-time-value (find-package "KEYWORD"))))
(defun sexp-for-package (package-designator &optional (prepare-token (function string-prepare-token)))
"
RETURN: A defpackage form corresponding to the package given by
PACKAGE-DESIGNATOR.
PREPARE-TOKEN: A function taking a kind (member :package :symbol) and
a package name or symbol, and returning a string
designator corresponding to that name. The functions
STRING-PREPARE-TOKEN, UNINTERNED-PREPARE-TOKEN or
KEYWORD-PREPARE-TOKEN may be used, or other custom
functions if different kind of string designators are
required for package names than for symbol names.
"
(let ((package (find-package package-designator)))
(assert package)
(let* ((used-packages (package-use-list package))
(used-symbols (mapcan (function com.informatimago.common-lisp.cesarum.package:package-exports)
used-packages))
(shadows '())
(shadowing-imports (make-hash-table))
(exports (com.informatimago.common-lisp.cesarum.package:package-exports package))
(shadowed-symbols (package-shadowing-symbols package))
(imports (make-hash-table)))
(do-symbols (sym package)
(unless (member sym exports)
(let ((home (symbol-package sym)))
(unless (or (eq home package)
(member sym shadowed-symbols)
(member sym used-symbols)
(member home used-packages))
(push sym (gethash home imports '()))))))
(dolist (sym shadowed-symbols)
(let ((home (symbol-package sym)))
(if (eq home package)
(push sym shadows)
(push sym (gethash home shadowing-imports '())))))
(flet ((pname (x) (funcall prepare-token :package x))
(sname (x) (funcall prepare-token :symbol x)))
`(defpackage ,(pname (package-name package))
,@(when (package-nicknames package)
`((:nicknames ,@(mapcar (function pname) (package-nicknames package)))))
(:use ,@(mapcar (lambda (p) (pname (package-name p))) used-packages))
,@(when shadows
`((:shadow ,@(mapcar (function sname) shadows))))
,@(when exports
`((:export ,@(mapcar (function sname) exports))))
,@(when (plusp (hash-table-count shadowing-imports))
(let ((forms '()))
(maphash (lambda (pack syms)
(push `(:shadowing-import-from
,(pname (package-name pack))
,@(mapcar (function sname) syms))
forms))
shadowing-imports)
forms))
,@(when (plusp (hash-table-count imports))
(let ((forms '()))
(maphash (lambda (pack syms)
(push `(:import-from
,(pname (package-name pack))
,@(mapcar (function sname) syms))
forms))
imports)
forms)))))))
;;;; THE END ;;;;
......@@ -116,27 +116,37 @@ MAX-EXTEND: NIL ==> double the buffer size, or double the buffer size until
it's greater than MAX-EXTEND, and then increment by MAX-EXTEND.
RETURN: A vector containing the elements read from the STREAM.
"
(let* ((busize (or length (ignore-errors (file-length stream)) min-size))
(eltype (stream-element-type stream))
(initel (if (subtypep eltype 'integer) 0 #\space))
(buffer (make-array busize
:element-type eltype
:initial-element initel
:adjustable t :fill-pointer t))
(start 0))
(loop
(let ((end (read-sequence buffer stream :start start)))
(when (or (< end busize) (and length (= length end)))
;; we got eof, or have read enough
(setf (fill-pointer buffer) end)
(return-from contents-from-stream buffer))
;; no eof; extend the buffer
(setf busize
(if (or (null max-extend) (<= (* 2 busize) max-extend))
(* 2 busize)
(+ busize max-extend))
start end))
(adjust-array buffer busize :initial-element initel :fill-pointer t))))
(let ((dirs (pathname-directory (pathname stream))))
(if (and (eql :absolute (pop dirs))
(member (pop dirs) '("proc" "sys" "dev") :test (function string=)))
;; some implementations have problem reading those file systems with read-sequence
;; so we fallback to read-line:
(with-output-to-string (out)
(loop
:for line = (read-line stream nil nil)
:while line :do (write-line line out)))
;; normal case:
(let* ((busize (or length (ignore-errors (file-length stream)) min-size))
(eltype (stream-element-type stream))
(initel (if (subtypep eltype 'integer) 0 #\space))
(buffer (make-array busize
:element-type eltype
:initial-element initel
:adjustable t :fill-pointer t))
(start 0))
(loop
(let ((end (read-sequence buffer stream :start start)))
(when (or (< end busize) (and length (= length end)))
;; we got eof, or have read enough
(setf (fill-pointer buffer) end)
(return-from contents-from-stream buffer))
;; no eof; extend the buffer
(setf busize
(if (or (null max-extend) (<= (* 2 busize) max-extend))
(* 2 busize)
(+ busize max-extend))
start end))
(adjust-array buffer busize :initial-element initel :fill-pointer t))))))
......@@ -374,4 +384,4 @@ RETURN: The last position.
(get-position ,var)))
;;;; stream.lisp -- -- ;;;;
;;;; THE END ;;;;
......@@ -38,9 +38,11 @@
(declaim (also-use-packages "ASDF"))
(defpackage "COM.INFORMATIMAGO.TOOLS.MANIFEST"
(:use "COMMON-LISP"
"COM.INFORMATIMAGO.COMMON-LISP.SCRIPT"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STRING"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.VERSION"
"COM.INFORMATIMAGO.COMMON-LISP.CESARUM.FILE"
"SPLIT-SEQUENCE")
(:export "ASDF-SYSTEM-NAME"
"ASDF-SYSTEM-LICENSE"
......@@ -302,7 +304,7 @@ into the keyword package."
ye mo da ho mi se (minusp tz) (abs (* 100 tz)))))
(defun print-manifest (system)
(defun print-manifest (&optional system)
(let* ((entries '(date
lisp-implementation-type
lisp-implementation-version
......@@ -314,19 +316,20 @@ into the keyword package."
(dolist (fun entries)
(format t "~(~VA~) : ~A~%" width fun (funcall fun))))
(terpri)
(let* ((entries (sort (mapcar (lambda (system)
(list system (asdf-system-license system)))
(system-depends-on/recursive system))
'string< :key 'first))
(system-width (reduce 'max entries :key (lambda (x) (length (first x)))))
(license-width (reduce 'max entries :key (lambda (x) (length (string (second x)))))))
(format t "~:(~VA~) ~:(~A~)~%~V,,,'-<~> ~V,,,'-<~>~%"
system-width 'system "license"
system-width license-width)
(loop
:for (system license) :in entries
:do (format t "~VA ~A~%" system-width system license))
(format t "~V,,,'-<~> ~V,,,'-<~>~%" system-width license-width)))
(when system
(let* ((entries (sort (mapcar (lambda (system)
(list system (asdf-system-license system)))
(system-depends-on/recursive system))
'string< :key 'first))
(system-width (reduce 'max entries :key (lambda (x) (length (first x)))))
(license-width (reduce 'max entries :key (lambda (x) (length (string (second x)))))))
(format t "~:(~VA~) ~:(~A~)~%~V,,,'-<~> ~V,,,'-<~>~%"
system-width 'system "license"
system-width license-width)
(loop
:for (system license) :in entries
:do (format t "~VA ~A~%" system-width system license))
(format t "~V,,,'-<~> ~V,,,'-<~>~%" system-width license-width))))
(defun write-manifest (program-name system)
......@@ -353,18 +356,28 @@ DO: write a {program-name}-{distribution}.manifest file for the given SYSTEM
;; TODO: see if we couldn't merge print-bug-report-info and print-manifest.
(defun print-bug-report-info ()
"Prints information for a bug report."
(format t "~2%~{~28A ~S~%~}~2%"
(list "LISP-IMPLEMENTATION-TYPE" (lisp-implementation-type)
"LISP-IMPLEMENTATION-VERSION" (lisp-implementation-version)
"SOFTWARE-TYPE" (software-type)
"SOFTWARE-VERSION" (software-version)
"MACHINE-INSTANCE" (machine-instance)
"MACHINE-TYPE" (machine-type)
"MACHINE-VERSION" (machine-version)
"*FEATURES*" *features*))
(let ((*print-pretty* t)
(*print-right-margin* 80))
(format t "~2%~{~28A ~S~%~}~2%"
(list "LISP-IMPLEMENTATION-TYPE" (lisp-implementation-type)
"LISP-IMPLEMENTATION-VERSION" (lisp-implementation-version)
"SOFTWARE-TYPE" (software-type)
"SOFTWARE-VERSION" (software-version)
"MACHINE-INSTANCE" (machine-instance)
"MACHINE-TYPE" (machine-type)
"MACHINE-VERSION" (machine-version)
"distribution" (distribution)
"uname -a" (ignore-errors (uname :a))
"*FEATURES*" *features*)))
(let ((cpuinfo (text-file-contents "/proc/cpuinfo" :if-does-not-exist nil)))
(when cpuinfo
(format t "~2%/proc/cpuinfo~%-------------~2%")
(write-string cpuinfo)
(terpri)))
#+clisp (with-open-stream (input (ext:run-program "uname" :arguments '("-a") :output :stream))
(format t ";;; uname -a~%")
(loop :for line = (read-line input nil nil) :while line :do (format t "~A~%" line)))
......
......@@ -604,7 +604,7 @@ with standard output to *SHELL-OUTPUT*, and standard error to *SHELL-ERROR*.
Returns the shell's exit code.
"
(let ((command (apply (function format) nil control-string arguments)))
(write-line command) (finish-output)
#+abcl
(ext:run-shell-command command :output *shell-output*)
......@@ -675,7 +675,7 @@ Returns the shell's exit code.
With options, returns the first line output by uname(1)."
(flet ((first-line (text) (subseq text 0 (position #\newline text))))
(let ((uname (with-output-to-string (*shell-output*)
(shell "uname ~A" (prepare-options options)))))
(shell "uname ~{~A~^ ~}" (prepare-options options)))))
(values (if options
(first-line uname)
(intern (string-upcase (first-line uname))
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment