ql-info-dump1 (Update for easy-acceptors)

(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))))))))