(defpackage :ql-info-dump1
(:use :cl :cl-ppcre :hunchentoot :cl-who))
(in-package :ql-info-dump1)
(ql:quickload "hunchentoot")
(ql:quickload "cl-ppcre")
(ql:quickload "cl-who")
(defparameter *web-server* NIL)
(defparameter *server-port* 8080)
(defvar *utf-8* (flex:make-external-format :utf-8 :eol-style :lf))
(setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format
:utf-8 :eol-style :lf))
(defparameter hunchentoot:reply-external-format (flex:make-external-format
:utf-8 :eol-style :lf))
(setf hunchentoot:*default-content-type* "text/html; charset=utf-8")
(setf *web-server* (make-instance 'hunchentoot:easy-acceptor :port *server-port*))
(hunchentoot:start *web-server*)
(push (hunchentoot:create-folder-dispatcher-and-handler
"/css/"
"/home/sabra/quicklisp/local-projects/ql-info-dump/css/")
hunchentoot:*dispatch-table*)
(push (hunchentoot:create-folder-dispatcher-and-handler
"/xhtml/"
"/home/sabra/quicklisp/local-projects/ql-info-dump/docs/xhtml/")
hunchentoot:*dispatch-table*)
;; ------------------- Helper Functions ----------------------------
(defun list-quicklisp-package-names ()
"lists the package names of the quicklisp libraries"
(let ((package-list (ql:system-list))
(package-list-strings ()))
(dolist (x package-list)
(let ((string-x
(cl-ppcre:regex-replace-all
"#<QL-DIST:SYSTEM |>"
(write-to-string x) "")))
(push (first (cl-ppcre:split " / " string-x)) package-list-strings)))
(sort package-list-strings #'string<)))
(defun list-current-systems ()
"Just return a list of all the current systems."
(let ((system-list ()))
(flet ((push-pkg-to-system-list
(pkg)
(push (asdf:component-name pkg) system-list)))
(asdf:map-systems #'push-pkg-to-system-list))
(sort system-list #'string<)))
(defun deal-with-plus (string)
"Take a string and replace any spaces with a plus sign."
(cl-ppcre:regex-replace-all " " string "+"))
(defun get-external-functions (name)
"Returns a list of the external function names for the named package.
Package is a string. It drops the references to the package name."
(let* ((package-name (if (stringp name) (read-from-string name) name))
(package (if (symbolp package-name) (find-package package-name))))
(when (packagep package)
(let ((lst ()))
(do-external-symbols (s package)
(when (sb-introspect:function-type s)
(push (write-to-string s) lst)))
(sort lst #'string<)))))
(defun get-external-non-functions (name)
"Returns a list of the external function names for the named package.
Package is a string. It drops the references to the package name."
(let* ((package-name (if (stringp name) (read-from-string name) name))
(package (if (symbolp package-name) (find-package package-name))))
(when (packagep package)
(let ((lst ()))
(do-external-symbols (s package)
(unless (sb-introspect:function-type s)
(push (write-to-string s) lst)))
(sort lst #'string<)))))
(defun pkg-file-location (file-name pkg-name)
"Given a file name string, returns the full directory location
if the file exists or nil"
(let ((package-name-symbol (read-from-string pkg-name)))
(when (ignore-errors (asdf:find-system package-name-symbol))
(let ((file-exists
(cl-fad:file-exists-p
(concatenate 'string (namestring
(asdf:system-source-directory
(asdf:find-system package-name-symbol))) file-name))))
(when file-exists (namestring file-exists))))))
(defun documented-functions (function-list)
"Takes a list of function names and returns 2 values, the number
of functions with a documenation string and the number of functions
without a documentation string"
(let ((documented 0)
(undocumented 0)
(total (length function-list)))
(loop for x in function-list
do
(let ((function-name (read-from-string x)))
(when (symbolp function-name)
(if (documentation function-name 'function)
(incf documented)
(incf undocumented)))))
(values total documented undocumented)))
;; ------------------- Page Section Areas ----------------------------
(defun banner ()
"Just a banner"
(cl-who:with-html-output-to-string (*standard-output* nil :indent t)
(cl-who:htm
(:h1 "QuickLisp Info Dump"))))
(defun navigation ()
"Just a nav section"
(cl-who:with-html-output-to-string
(*standard-output* nil :indent t)
(cl-who:htm
(:h3 "Loaded Packages")
(loop for x in (list-current-systems)
do (cl-who:htm (:a :href (concatenate 'string "display-package?name=" x)
(cl-who:str x))
(:br))))))
(defun extra-stuff ()
"Just some extra stuff"
(cl-who:with-html-output-to-string (*standard-output* nil :indent t)
(cl-who:htm
(:h3 "Extras")
(:a :href "list-quicklisp-libraries" (cl-who:str"List QuickLisp Libraries"))
(:br)
(:a :href "compare-packages" (cl-who:str"Compare 2 Loaded Packages"))
(:br)
(:a :href "docs/xhtml/begin-building-webapp.xhtml"
(cl-who:str"How to Build this Webapp")))))
(defun footer-area ()
"Just some footer stuff"
(cl-who:with-html-output-to-string (*standard-output* nil :indent t)
(cl-who:htm
(:table (:tr
(:td (:a :href "http://www.quicklisp.org"
(cl-who:str"Quicklisp")))
(:td (:a :href "http://common-lisp.net/"
(cl-who:str"Common-Lisp.net")))
(:td (:a :href "http://planet.lisp.org/"
(cl-who:str"Planet Lisp")))
(:td (:a :href "http://planet.cliki.net/"
(cl-who:str"Planet Cliki")))
(:td (:a :href "http://planet.sbcl.org/"
(cl-who:str"Planet SBCL")))
(:td (:a :href "http://cl-user.net/"
(cl-who:str"CL Directory")))
(:td (:a :href "http://www.lisp.org/alu/home"
(cl-who:str"ALU")))
(:td (:a :href "http://www.lispworks.com/documentation/HyperSpec/Front/"
(cl-who:str"Lispworks HyperSpec"))))))))
(defun flatten (orig-list)
"Takes a nested list and returns a single list with all the
previously nested elements."
(if (eql orig-list nil)
nil
(let ((elem (car orig-list)) (resto-list (cdr orig-list)))
(if (listp elem)
(append (flatten elem) (flatten resto-list))
(append (cons elem nil) (flatten resto-list))))))
(defun find-asdf-system-file (package-string)
"Returns a pathname of the asd file for this package."
(ql-dist:find-asdf-system-file package-string))
(defun direct-dependencies (component)
(cdadr (asdf:component-depends-on 'asdf:load-op
(asdf:find-component nil component))))
(defun normalize-system-id (id)
(intern (symbol-name id) "KEYWORD"))
(defun ensure-list (lst)
"From Alexandria. If the parameter is a list, it is returned.
Otherwise it turns the parameter into a list and returns that."
(if (listp lst)
lst
(list lst)))
(defun %effective-dependencies (components)
"Helper function from
http://blog.viridian-project.de/2008/07/13/collecting-asdf-system-dependencies/."
(when components
(remove-duplicates
(append components
(%effective-dependencies
(mapcar #'normalize-system-id
(remove-if #'null
(flatten
(mapcar #'direct-dependencies
components))))))
:test #'eq)))
(defun effective-dependencies (components)
"Find all dependencies needed for the list of COMPONENTS
(which may be an atom, too). From http://blog.viridian-project.de/
2008/07/13/collecting-asdf-system-dependencies/"
(let ((components (ensure-list components)))
(set-difference (%effective-dependencies components) components
:key #'normalize-system-id)))
(defun gridify1 (x base-parameter &optional (col 5))
"Given a list of strings, put them in html tbody rows (returned as a
string) with |col| columns. Obviously this requires that the calling function
has provided the table and thead information."
(let* ((length (length x))
(cell-mod (mod length col))
(extra-cells (if (= cell-mod 0) 0 (- col cell-mod))))
(cl-who:with-html-output-to-string (var nil)
(cl-who:htm
(:tbody
(loop for xp on x by (lambda (p) (nthcdr col p))
do
(cl-who:htm (:tr
(loop for i upto (1- col) for package-name in xp
do (cl-who:htm
(:td
(:a :href
(format nil "~a~a" base-parameter
(string-downcase package-name))
(cl-who:str (string-downcase package-name)))))))))
(dotimes (i extra-cells)
(cl-who:htm (:td))))))))
(defmacro defpage-easy-d (name title uri parameter-list docs &body body)
"Generates the html page and includes a page template"
`(hunchentoot:define-easy-handler (,name :uri ,uri
:default-request-type :both)
,parameter-list ,docs
(page-template ,title
,@body)))
(defmacro page-template (title &body body)
"Generates the basic html page template with css"
`(cl-who:with-html-output-to-string (*standard-output* nil :prologue t :indent t)
(:html
(:head
(:meta :http-equiv "Content-Type"
:content "text/html;charset=utf-8")
(:title (cl-who:str (format nil " ~a" ,title)))
(:link :rel "stylesheet" :type "text/css" :href "/css/base.css"
:media "screen"))
(:body
(:div :id "container"
(:div :id "header"
(cl-who:str (banner)))
(:div
(:div :id "content"
(cl-who:str ,@body))
(:div :id "navigation"
(cl-who:str (navigation)))
(:div :id "extra"
(cl-who:str (extra-stuff)))
(:div :id "footer"
(cl-who:str (footer-area)))))))))
(defmacro page-template-1 (title &body body)
"Generates the basic html page template with css with no navigation
or extras section."
`(cl-who:with-html-output-to-string (*standard-output* nil :prologue t :indent t)
(:html
(:head
(:meta :http-equiv "Content-Type"
:content "text/html;charset=utf-8")
(:title (cl-who:str (format nil " ~a" ,title)))
(:link :rel "stylesheet" :type "text/css" :href "/css/base.css"
:media "screen"))
(:body
(:div :id "container"
(:div :id "header"
(cl-who:str (banner)))
(:div
(:div :id "content1"
(cl-who:str ,@body))
(:div :id "footer"
(cl-who:str (footer-area)))))))))
(defmacro defpage-easy-d-1 (name title uri parameter-list docs &body body)
"Generates the html page and includes a page template
with no navigation or extras section."
`(hunchentoot:define-easy-handler (,name :uri ,uri
:default-request-type :both)
,parameter-list ,docs
(page-template-1 ,title
,@body)))
(defpage-easy-d list-quicklisp-libraries "list-quicklisp-libraries"
"/list-quicklisp-libraries"
()
"Lists the quicklisp libraries."
(cl-who:with-html-output-to-string
(*standard-output*)
(cl-who:htm
(:h1 "Available QuickLisp Libraries"))
(loop for x in (nreverse
(set-difference
(list-quicklisp-package-names)
(list-current-systems) :test 'equal))
do (cl-who:htm (:a :href (concatenate 'string "load-library?name=" x)
(cl-who:str x))
(:br)))))
(defpage-easy-d home-page "QLID" "/" ()
"Handles base page."
(cl-who:with-html-output-to-string (*standard-output*)
(cl-who:htm
(:h1 "Yes, we have bananas."))))
(defmacro defsnippet-with-docs (name args docs &body body)
"A defsnippet-with-docs is a defsnippet with a documentation string."
`(defun ,name ,args
,docs
(cl-who:with-html-output (*standard-output* nil :prologue nil :indent t)
,@body)))
(defsnippet-with-docs package-overview (system-name named-system)
"Returns html of functions which call the function-name string"
(let ((function-list (get-external-functions system-name)))
(multiple-value-bind
(total-functions documented-functions undocumented-functions)
(documented-functions function-list)
(cl-who:htm
(:div
(:table
(:tr (:td (:a :href
(concatenate 'string "http://www.cliki.net/admin/search?words="
system-name) (cl-who:str "Cliki Search")))
(:td)
(:td
(:a :href (concatenate 'string
"http://www.lispdoc.com/?search=Basic+search&q="
system-name) (cl-who:str "Lispdoc.com Search"))))
(:tr (:th "Author")
(:td (cl-who:str
(ignore-errors (asdf:system-author named-system))))
(:th "License")
(:td (cl-who:str (ignore-errors (asdf:system-license named-system)))))
(:tr
(loop for x in '("LICENSE" "COPYING" "README" "CHANGES" "CHANGELOG"
"AUTHORS" "INSTALL" )
do (if (pkg-file-location x system-name)
(cl-who:htm
(:td (:a :href
(concatenate 'string "file:"
(pkg-file-location x system-name))
(cl-who:str x))))))
(when (asdf:system-source-file named-system)
(cl-who:htm (:td (:a :href
(concatenate 'string "file:"
(namestring
(asdf:system-source-file named-system)))
(cl-who:str (concatenate 'string system-name ".asd")))))))
(:tr
(:th "Exported Functions")
(:td (cl-who:str (write-to-string total-functions)))
(:th "Documented ")
(:td (cl-who:str (write-to-string documented-functions)))
(:th "Undocumented")
(:td (cl-who:str (write-to-string undocumented-functions))))))))))
(defpage-easy-d display-package "display-package" "/display-package"
((name :parameter-type 'string))
"Handles package display requests."
(let* ((system-name (deal-with-plus name))
(named-system (ignore-errors (asdf:find-system system-name))))
(when named-system
(cl-who:with-html-output-to-string
(*standard-output*)
(cl-who:htm
(:h1 (cl-who:str system-name))
(package-overview system-name named-system)
(:div (:h2 "Description")
(cl-who:str (ignore-errors
(asdf:system-description
named-system))))
(:div (:h2 "Depends on")
(let* ((dependency-list
(effective-dependencies (read-from-string system-name))))
(cl-who:htm (:table
(cl-who:str (gridify1 dependency-list "display-package?name="))))))
(:div (:table (:tr (:td (:a :href "#exported-functions"
(cl-who:str "Exported Functions")))
(:td (:a :href "#exported-variables"
(cl-who:str "Exported Variables"))))))
(:div (:h2 (:a :name "exported-functions" (cl-who:str "Exported Functions")))
(loop for x in (get-external-functions system-name)
do (cl-who:htm
(:a :href (concatenate 'string "display-function?name=" x)
(cl-who:str x))
(:br))))
(:div (:h2 (:a :name "exported-variables" (cl-who:str "Exported Variables")))
(loop for x in (get-external-non-functions system-name)
do (cl-who:htm
(:a :href (concatenate 'string "display-variable?name=" x)
(cl-who:str x))
(:br)))))))))
(defun write-car-to-string (item)
"This is a specialized helper function for sorting calling functions."
(write-to-string (car item)))
(defsnippet-with-docs calling-functions (function-name)
"Returns html of functions which call the function-name string"
(:h3 "Functions that call this function")
(let ((caller-list ()))
(loop for x in
(sort
(sb-introspect:who-calls (read-from-string function-name))
#'string< :key #'write-car-to-string)
do
(unless (member (car x) caller-list)
(push (car x) caller-list)
(let ((caller-pathname
(ignore-errors
(namestring
(sb-introspect:definition-source-pathname
(cdr x))))))
(if caller-pathname
(cl-who:htm (:a :href (concatenate 'string "file:" caller-pathname)
(cl-who:str (car x)))
(:br))))))))
(defpage-easy-d display-function "display-function" "/display-function"
((name :parameter-type 'string))
"Handles function display requests."
(if (ignore-errors (fdefinition (read-from-string name)))
(let* ((package-name (first (cl-ppcre:split ":" name)))
(file-pathname
(ignore-errors
(namestring (sb-introspect:definition-source-pathname
(sb-introspect:find-definition-source
(fdefinition (read-from-string name))))))))
(cl-who:with-html-output-to-string
(*standard-output*)
(cl-who:htm
(:h2 "Package: " (:a :href
(concatenate 'string "display-package?name="
package-name) (cl-who:str package-name)))
(:h2 (cl-who:str name))
(:h3 "Documentation String")
(cl-who:str (documentation (read-from-string name) 'function))
(:br)
(:h3 "Source File")
(if file-pathname
(cl-who:htm (:a :href (concatenate 'string "file:" file-pathname)
(cl-who:str name)))
(cl-who:htm (cl-who:str "No file-pathname found!")))
(:h3 "Functions that call this function")
(calling-functions name))))
(cl-who:with-html-output-to-string
(*standard-output*)
(cl-who:htm
(:h2 (cl-who:str (concatenate 'string "Unknown function: " name)))))))
(defpage-easy-d display-variable "display-variable" "/display-variable"
((name :parameter-type 'string))
"Handles function display requests."
(if name
(let* ((package-name (first (cl-ppcre:split ":" name)))
(file-pathname
(ignore-errors
(namestring (sb-introspect:definition-source-pathname
(sb-introspect:find-definition-source
(fdefinition (read-from-string name))))))))
(cl-who:with-html-output-to-string
(*standard-output*)
(cl-who:htm
(:h2 "Package: " (:a :href
(concatenate 'string "display-package?name="
package-name) (cl-who:str package-name)))
(:h2 (cl-who:str name))
(:h3 "Documentation String")
(cl-who:str (if (documentation (read-from-string name) 'variable)
(documentation (read-from-string name) 'variable)
(if (documentation (read-from-string name) 'function)
(documentation (read-from-string name) 'function)
"No Documentation Available")))
(:br)
(:h3 "Source File")
(if file-pathname
(cl-who:htm (:a :href (concatenate 'string "file:" file-pathname)
(cl-who:str name)))
(cl-who:htm (cl-who:str "No file-pathname found!")))
(:h3 "Functions that call this Macro or Variable")
(calling-functions name))))
(cl-who:with-html-output-to-string
(*standard-output*)
(cl-who:htm
(:h2 (cl-who:str (concatenate 'string "Unknown Variable or Macro: " name)))))))
(defpage-easy-d load-library "Load Library" "/load-library"
((name :parameter-type 'string))
"Takes a name parameter from from hunchentoot, tries to load that
library name, then redirects, back to the home page. Quickload will
print a successful result of the attempting loading to the main page.
Any errors will be triggered in the REPL."
(when (ql:quickload name)
(hunchentoot:redirect "/")))
(defpage-easy-d-1 compare-packages "Compare Packages" "/compare-packages"
((pkg1 :parameter-type 'string)(pkg2 :parameter-type 'string))
"Generate a form to choose which packages to compare"
(cl-who:with-html-output-to-string
(*standard-output*)
(cl-who:htm
(:div (:form :method :get :action "compare-packages"
(:select :name "pkg1"
(loop for name in (list-current-systems)
do (cl-who:htm
(:option :value name
(cl-who:str name)))))
(:select :name "pkg2"
(loop for name in (list-current-systems)
do (cl-who:htm
(:option :value name
(cl-who:str name)))))
(:input :type "submit")))
(:div (:div :id "col1"
(loop for name in (get-external-functions pkg1)
do (cl-who:htm (:a :href
(concatenate 'string
"display-function?name="
name)
(cl-who:str name)) (:br))))
(:div :id "col2"
(loop for name in (get-external-functions pkg2)
do (cl-who:htm (:a :href
(concatenate 'string "display-function?name="
name)
(cl-who:str name)) (:br))))))))