Inspired by Zach Bean's Quicklisp, I decided to challenge myself and see how fast I could create a webapp that showed as much data as possible from the quicklisp libraries (and anywhere else I could semi-automate.) For lack of a more creative title, I'm going to call the lisp package that I'm creating "ql-info-dump."
I'm going to start with the assumption that you have have a lisp implementation. Unfortunately, looking into system internals does vary from lisp implementation to lisp implementation. I'm writing this based on running Linux with SBCL 1.0.43, your mileage may vary.
This basic version does not require a database. Constructive criticism on anything in the tutorial is also appreciated. Unconstructive criticism will be filed in /dev/null with an automatic suggestion that you write the next tutorial.
Ok. So we are going to try to get the bare minimum webpage up and running and then start to build from there.
Load quicklisp, hunchentoot, cl-who, cl-ppcre,
We will need a few libraries from quicklisp, so get into quicklisp and run the following:
(ql:quickload "hunchentoot")(ql:quickload "cl-ppcre")(ql:quickload "cl-who")Hunchentoot is a webserver written in common lisp. Cl-ppcre is a regex library for common lisp. cl-who is an html generating library for common lisp.
Test hunchentoot
So let's just test and make sure hunchentoot actually loads and works for us. We will load the hunchentoot-test demo, change to the hunchentoot-test package make an instance of the webserver and set it to the global parameter web-server and then actually start the webserver.
CL-USER> (ql:quickload "hunchentoot-test")("hunchentoot-test")CL-USER> (in-package :hunchentoot-test)#<PACKAGE "HUNCHENTOOT-TEST">TBNL-TEST> (defparameter *web-server* (setf *web-server* (make-instance 'easy-acceptor :port 4242)))TBNL-TEST> (start *web-server* )#<ACCEPTOR (host *, port 4242)>If you now point your browser to http://127.0.0.1:4242/hunchentoot/test/easy-demo.html you should actually see the hunchentoot server providing the demo page.
Note: If you are using a version of hunchentoot pre 1.2.1, then change "easy-acceptor" to "acceptor". Then ask yourself why you are using an older version.
You can play with this for awhile and then close this demo server.
TBNL-TEST> (hunchentoot:stop *web-server*)Configure the Webserver and start it up
First we are going to create a quick and dirty page that just shows what packages are currently running in your lisp instance. We first create two parameters, one for the webserver and one for the port where hunchentoot will direct the pages. Note that I did change the port being used from 4242 to 8080 (just personal preference).
(defparameter *web-server* NIL)(defparameter *server-port* 8080)Assuming you want to have the hunchentoot server outputing in UTF-8 rather than iso-8859-1, then you need to set these parameters.
(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")You can actually create a hunchentoot instance and have it running without assigning it to a parameter, but then you have no easy way to identify it when you want to stop and restart it.
So now, let's create a hunchentoot instance and start the webserver.
(setf *web-server* (make-instance 'hunchentoot:easy-acceptor :port *server-port*))(hunchentoot:start *web-server*)At this point, if you click on http://localhost:8080 you should get the hunchentoot default page. We want to start with the hunchentoot equivalent of hello world, then build on that. I will go a little crazy, however, if I have to preface every cl-who function with the package name, so lets define a package ql-info-dump which uses cl-ppcre, hunchentoot and cl-who. Other, more experienced, lisp programmers will argue that you should always preface functions with the package name. I have definitely found myself in situations where I would agree with them. You can decide for yourself. The source code version on the next page does preface the functions, just so you can see the difference.
(defpackage :ql-info-dump1 (:use :cl :cl-ppcre :hunchentoot :cl-who))(in-package :ql-info-dump1)Hunchentoot has a really nice basic page macro called "define-easy-handler". In its simplest form, it takes a symbol name, a uri, a request type, a parameter list. In the following macro, I've extended it slightly to require a documentation string and insert a page template.
The page template provides the head and some basic body css and will eventually be modified to pick up some javascript. We then set up some functions to generate header, navigation, extra and footer stuff and the home page itself.
(defmacro defpage-easy-d (name title uri parameter-list docs &body body) "Generates the html page and includes a page template" `(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" `(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 (str (format nil " ~a" ,title))) (:link :rel "stylesheet" :type "text/css" :href "/css/base.css" :media "screen")) (:body (:div :id "container" (:div :id "header" (str (banner))) (:div (:div :id "content" (str ,@body)) (:div :id "navigation" (str (navigation))) (:div :id "extra" (str (extra-stuff))) (:div :id "footer" (str (footer-area)))))))))The page template above indicates that we are going to have basically five areas of on the page:a banner,navigation, extra-stuff,footer and main content. Later on, we will also make a new template for a comparison page which will have the header, footer and two center comparison columns.
Note that the template calls for a css file which we will get to shortly and also indicates that the character set encoding will be utf-8.
So, we need functions which will fill up these areas of the page. We can start with just something to fill in, but we'll add several lisp links
for the footer in case we want to jump off the page and go look for something.
(defun banner () "Just a banner" (with-html-output-to-string (*standard-output* nil :indent t) (htm (:h1 "QuickLisp Info Dump"))))(defun navigation () "Just a nav section" (with-html-output-to-string (*standard-output* nil :indent t) (htm (:h3 "Loaded Packages"))))(defun extra-stuff () "Just some extra stuff" (with-html-output-to-string (*standard-output* nil :indent t) (htm (:h3 "Extras"))))(defun footer-area () "Just some footer stuff" (with-html-output-to-string (*standard-output* nil :indent t) (htm (:table (:tr (:td (:a :href "http://www.quicklisp.org" (str "Quicklisp"))) (:td (:a :href "http://common-lisp.net/" (str "Common-Lisp.net"))) (:td (:a :href "http://planet.lisp.org/" (str "Planet Lisp"))) (:td (:a :href "http://planet.cliki.net/" (str "Planet Cliki"))) (:td (:a :href "http://planet.sbcl.org/" (str "Planet SBCL"))) (:td (:a :href "http://cl-user.net/" (str "CL Directory"))) (:td (:a :href "http://www.lisp.org/alu/home" (str "ALU"))) (:td (:a :href "http://www.lispworks.com/documentation/HyperSpec/Front/" (str "Lispworks HyperSpec"))))))))Oh yeah. Now we need a css file. If we look at the page template above, hunchentoot will expect a css directory and a css file named "base.css" Without an additional instruction to hunchentoot, however, it will not be able to find that file. Make a directory, and insert the following basic css in it (or any other css you would prefer).
html,body{margin:0;padding:0}body{font: 76% arial,sans-serif;text-align:center}p{margin:0 10px 10px}a{padding:5px; text-decoration:none; color:#000000;}div#header{background-color:#cce6e1;}div#header h1{height:80px;line-height:80px;margin:0;padding-left:10px;}div#container{text-align:left}div#content p{line-height:1.4}div#navigation{background:#cce6ff;}div#navigation ul{margin:15px 0; padding:0; list-style-type:none;}div#navigation li{margin-bottom:5px;}div#extra{background:#cce6ff;}div#footer{background:#cce6e1;}div#footer p{margin:0;padding:5px 10px}div#container{width:900px;margin:0 auto}div#content{float:right;width:700px;height: 600px;overflow:scroll;background:#ccffff}div#content1{width:900px;height: 600px;background:#ccffff;}div#navigation{float:left;width:200px;height: 500px;overflow:scroll}div#extra{float:left;clear:left;width:200px;height: 100px}div#footer{clear:both;width:100%}div#col1{float :left;width: 450px;margin:4; overflow: scroll;height:600px}div#col2{float :left;width: 450px;margin:4; overflow: scroll;height:600px}a {color:#009;text-decoration:underline;}Now we need to tell hunchentoot where to find the file. You can either tell hunchentoot where to find this specific file or, my preference, you can tell hunchentoot what directory contains css files. This needs to be an absolute directory location. While I'm at it, I will also push the directory for xhtml documentation files.
(push (hunchentoot:create-folder-dispatcher-and-handler "/css/" "/home/sc/projects/ql-info-dump/css/") hunchentoot:*dispatch-table*)(push (hunchentoot:create-folder-dispatcher-and-handler "/xhtml/" "/home/sc/projects/ql-info-dump/docs/xhtml/") hunchentoot:*dispatch-table*)Now we can create the homepage and everything should come together.
(defpage-easy-d home-page "QLID" "/" () "Handles base page." (with-html-output-to-string (*standard-output*) (:htm (:h1 "Yes, we have bananas."))))If you re-click on http://localhost:8080 you should get a really ugly, but live page.
Now let's add some interesting stuff. What about showing all the currently loaded lisp packages in the navigation section? For that, we need to define a function to get a list of all the currently loaded "systems" or "packages". We'll return those names in a list, which can then be used in a redefined navigation function.
(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 navigation () "Just a nav section" (with-html-output-to-string (*standard-output* nil :indent t) (htm (:h3 "Loaded Packages") (loop for x in (list-current-systems) do (htm (:a :href (conc "display-package?name=" x) (str x)) (:br))))))Notice that we sorted the system list in alphabetical order prior to returning it. If you reclick on http://localhost:8080 you should get a navigation bar that has been loaded with entries. You thought you only loaded hunchentoot, cl-ppcre and cl-who? So why are there so many other packages listed? Quicklisp also loads the dependencies, so everything that hunchentoot itself needs is also loaded.
We also redefined the navigation section to not only load the names, but also wrap each in a href link. Since we have a link to display those functions, let's do something with them.
For that we need to define a page "display-package that takes a get parameter of name.
(defpage-easy-d display-package "display-package" "/display-package" ((name :parameter-type 'string)) "Handles package display requests." (with-html-output-to-string (*standard-output*) (:htm (:h1 (str name)))))Note the leading slash in from of the url. Other than the fact we have the name of the package in the main content area, the rest of the page is using the template, so it looks exactly like the homepage.
We'll now define a function to list the exported functions from the package.
(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<)))))(defpage-easy-d display-package "display-package" "/display-package" ((name :parameter-type 'string)) "Handles package display requests." (with-html-output-to-string (*standard-output*) (:htm (:h1 (str name)) (loop for x in (get-external-functions name) do (htm (:a :href (conc "display-function?name=" x) (str x)) (:br))))))Now if we click on a package in the navigation bar, we get a list of the exported functions in that package, with links to a new page "display-function". Now we need to create that page.
(defpage-easy-d display-function "display-function" "/display-function" ((name :parameter-type 'string)) "Handles function display requests." (when (symbolp (read-from-string name)) (let* ((package-name (first (cl-ppcre:split ":" name)))) (with-html-output-to-string (*standard-output*) (:htm (:h2 "Package: " (:a :href (conc "display-package?name=" package-name) (str package-name))) (:h2 (str name)) (:h3 "Documentation String") (str (documentation (read-from-string name) 'function)) (:br))))))As you play with this, you will notice that a lot of functions, even the exported functions, are not documented. Let's add a bit more information at the beginning and see what additional information we can get directly from the package or two other sources of lisp information (clikie.net and lispdoc.com).
We will try to pull up the author, description and number of functions documented and undocumented which are exported by the package.
In many cases, the author and description slots in the asdf package are unbound, so we can use the "ignore-errors" function to ensure a nil
return rather than an error.
We will first create a helper function that takes a function list and returns three values, the total number of functions, the number of functions with a documentation string and the number of functions without a documentation string. (In this case, we are only going to
be passing a list of the exported functions, not all package functions to the documented functions list.
(defun documented-functions (function-list) "Takes a list of function names and returns 2 values, the numberof functions with a documenation string and the number of functionswithout 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)))(defpage-easy-d display-package "display-package" "/display-package" ((name :parameter-type 'string)) "Handles package display requests." (let ((function-list (get-external-functions name))) (multiple-value-bind (total-functions documented-functions undocumented-functions) (documented-functions function-list) (with-html-output-to-string (*standard-output*) (:htm (:h1 (str name)) (:div (:table (:tr (:td (:a :href (conc "http://www.cliki.net/admin/search?words=" name) (str "Cliki Search"))) (:td (:a :href (conc "http://www.lispdoc.com/?search=Basic+search&q=" name) (str "Lispdoc.com Search")))) (:tr (:th "Author") (:td (str (ignore-errors (asdf:system-author (asdf:find-system name)))))) (:tr (:th "Description") (:td (str (ignore-errors (asdf:system-description (asdf:find-system name)))))) (:tr (:th "License") (:td (str (ignore-errors (asdf:system-license (asdf:find-system name)))))) (:tr (:th "# Exported Functions") (:td (str (write-to-string total-functions)))) (:tr (:th "# Documented Functions") (:td (str (write-to-string documented-functions)))) (:tr (:th "# Undocumented Functions") (:td (str (write-to-string undocumented-functions)))))) (:div (:h2 "Exported Functions") (loop for x in (get-external-functions name) do (htm (:a :href (conc "display-function?name=" x) (str x)) (:br)))))))))At this point, I've discovered that we don't properly handle the package "cl+ssl". That plus sign does not fit in well with standard url functions
and the plus tends to get treated as a space. If you click on the "cl+ssl" package in the navigation column, it will return exported functions for "cl" (the lisp system itself) because the space causes it to drop the "+ssl" part of the package name. There are a couple ways to deal with this. Right now I'll just take a quick and dirty solution and create a function that just takes the name string and inserts plus signs back in where a space exists.
(defun deal-with-plus (string) "Take a string and replace any spaces with a plus sign." (cl-ppcre:regex-replace-all " " string "+"))Let's change direction slightly and use that "Extras" area in the navigation bar provide links to additional information, starting with getting a list of all the available libraries from quicklisp.
Because there is no exported name method applicable to the quicklisp packages, we have to do a little bit of ugly text replacement to break out the name. We don't want to show the libraries which have already been loaded, so we use the "set-difference" function to reduce the total set of quicklisp libraries to the set of not currently loaded quicklisp libraries.
(defun extra-stuff () "Just some extra stuff" (with-html-output-to-string (*standard-output* nil :indent t) (htm (:h3 "Extras") (:a :href "list-quicklisp-libraries" (str "List QuickLisp Libraries")) (:br) (:a :href "docs/xhtml/begin-building-webapp.xhtml" (str "How to Build this Webapp")))))(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<)))(defpage-easy-d list-quicklisp-libraries "list-quicklisp-libraries" "/list-quicklisp-libraries" () "Lists the quicklisp libraries." (with-html-output-to-string (*standard-output*) (:htm (:h1 "Available QuickLisp Libraries")) (loop for x in (nreverse (set-difference (list-quicklisp-package-names) (list-current-systems) :test 'equal)) do (htm (:a :href (conc "load-library?name=" x) (str x)) (:br)))))We gave a link to the library names for load-library. Right now we have no security whatsoever, so you would never do this on a production server and behind a firewall, but let's actually provide a function that asks quicklisp to load the library and see if it now appears in the Navigation list.
(defpage-easy-d load-library "Load Library" "/load-library" ((name :parameter-type 'string)) "Handles package display requests." (ql:quickload name) (hunchentoot:redirect "/"))Now see if you can click on an unloaded package and see the result.
Suppose we want to compare the function list of two packages. First we need a way to choose which packages to consider, so we will need a page with a form, two select lists and a submit button.
Given the length of some of the function-names, I've also decide to create another page-template (page-template-1), and defpage-macro (defpage-easy-d-1) which drop the navigation and extras side panel in order to get more room on the webpage. Then we create the compare-packages page using these new templates and page-macro, put a link to the compare packages page into the extras function and we are on our way again.
(defmacro page-template-1 (title &body body) "Generates the basic html page template with css with no navigation or extras section." `(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 (str (format nil " ~a" ,title))) (:link :rel "stylesheet" :type "text/css" :href "/css/base.css" :media "screen")) (:body (:div :id "container" (:div :id "header" (str (banner))) (:div (:div :id "content1" (str ,@body)) (:div :id "footer" (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." `(define-easy-handler (,name :uri ,uri :default-request-type :both) ,parameter-list ,docs (page-template-1 ,title ,@body)))(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" (with-html-output-to-string (*standard-output*) (:htm (:div (:form :method :get :action "compare-packages" (:select :name "pkg1" (loop for name in (list-current-systems) do (htm (:option :value name (str name))))) (:select :name "pkg2" (loop for name in (list-current-systems) do (htm (:option :value name (str name))))) (:input :type "submit"))) (:div (:div :id "col1" (loop for name in (get-external-functions pkg1) do (htm (:a :href (conc "display-function?name=" name) (str name)) (:br)))) (:div :id "col2" (loop for name in (get-external-functions pkg2) do (htm (:a :href (conc "display-function?name=" name) (str name)) (:br))))))))(defun extra-stuff () "Just some extra stuff" (with-html-output-to-string (*standard-output* nil :indent t) (htm (:h3 "Extras") (:a :href "list-quicklisp-libraries" (str "List QuickLisp Libraries")) (:br) (:a :href "compare-packages" (str "Compare 2 Loaded Packages")) (:br) (:a :href "docs/xhtml/begin-building-webapp.xhtml" (str "How to Build this Webapp")))))So, you can now wander around the quicklisp libraries and look at the documentation strings and wonder why people don't write documentation strings for their exported functions. I know if I look at one of my functions six months after I wrote it, I prefer to have given myself a little bit of context before starting to read the source code.
You will also notice that a lot of libraries do not put the author or license in the asdf definition. Some packages have no author or license anywhere, others put them in text files or in comments in the asd file. In other words, the data is dirty and we have pretty much reached the end of the easily auto-generated information.
So, you know the name of the function, but now you need to read the source code. In emacs running slime, you can hit Meta-. give the name of the function to slime and it will automagically take you to the source code. We, however, are just surfing around the libraries in a browser, so what can we do to get to the text version of the source code (and check out whether there are any typical text files sitting around in the package?
The SBCL implementation of common lisp has functions that help here. I don't have other implementations, but they may or may not have similar functions. In any event, the following works on SBCL.
Consider the following function call and result from my box as I was writing this:
(sb-introspect:find-definition-source #'cl-fad:list-directory)#S(SB-INTROSPECT:DEFINITION-SOURCE :PATHNAME #P"/usr/share/common-lisp/source/cl-fad/fad.lisp" :FORM-PATH (5) :CHARACTER-OFFSET 3369 :FILE-WRITE-DATE 3495030243 :PLIST NIL :DESCRIPTION NIL)(sb-introspect:definition-source-pathname (sb-introspect:find-definition-source #'cl-fad:list-directory))#P"/usr/share/common-lisp/source/cl-fad/fad.lisp"What this tells us is that the function "list-directory" in the cl-fad package can be allegedly found in the file "/usr/share/common-lisp/source/cl-fad/fad.lisp".
This seems a bit strange since all the source files for quicklisp packages are in "/home/user-name/quicklisp/dists/quicklisp/software". On my machine, it turns out that if the lisp implementation already has the package loaded, then quicklisp will not load a local quicklisp copy of that package. Testing this on some packages that I did not already have loaded returned the expected location for the package function.
The "sb-introspect:definition-source-pathname" function returns a pathname object, not the string version of the fully qualified file location.
However, Hunchentoot depends on cl-fad, which can return a namestring from a pathname object, so we already have that capability loaded.
Looking for the string which would give me the fully qualified path to the source code file for the hunchentoot function "authorization" can then be done as.
(namestring (sb-introspect:definition-source-pathname (sb-introspect:find-definition-source #'hunchentoot:authorization)))"/home/sc/quicklisp/dists/quicklisp/software/hunchentoot-1.1.1/request.lisp"(file-namestring (sb-introspect:definition-source-pathname (sb-introspect:find-definition-source #'hunchentoot:authorization)))"request.lisp"So going back to the display-function in our little webapp, let's add a link to the file where the function actually exists.
(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)))))))) (with-html-output-to-string (*standard-output*) (:htm (:h2 "Package: " (:a :href (conc "display-package?name=" package-name) (str package-name))) (:h2 (str name)) (:h3 "Documentation String") (str (documentation (read-from-string name) 'function)) (:br) (:h3 "Source File") (if file-pathname (htm (:a :href (conc "file:" file-pathname) (str name))) (htm (str "No file-pathname found!")))))) (with-html-output-to-string (*standard-output*) (:htm (:h2 (str (conc "Unknown function: " name)))))))This gives you a link, which you an open by right-clicking on the link and opening it in a new page.
As mentioned previously, not every developer puts information into the asdf definition. Looking at the source directories, we notice a few
text files which are more common than others. For example LICENSE, COPYING, README, CHANGELOG, CHANGES, INSTALL, AUTHORS. So lets take those filenames and put links to them if they exist in the package directory.
We can get the pathname to the package directory using the asdf function system-source-directory. Let's create a function that returns the full file location if the file exists or blank otherwise.
(defun pkg-file-location (file-name pkg-name) "Given a file name string, returns the full directory locationif 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 (conc (namestring (asdf:system-source-directory (asdf:find-system package-name-symbol))) file-name)))) (when file-exists (namestring file-exists))))))Now we can go back to display package and insert the links if these files exist. We will also put in a link to the asd file. Unless someone deleted it after we loaded the library, that is one file we know should exist.
However, before we start, the function is getting too long for my taste. So lets create another little helper macro which will deal with small
snippets of html, then use it for the package overview, and call that from the "display-package" function.
(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) (htm (:div (:table (:tr (:td (:a :href (conc "http://www.cliki.net/admin/search?words=" system-name) (str "Cliki Search"))) (:td) (:td (:a :href (conc "http://www.lispdoc.com/?search=Basic+search&q=" system-name) (str "Lispdoc.com Search")))) (:tr (:th "Author") (:td (str (ignore-errors (asdf:system-author named-system)))) (:th "License") (:td (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) (htm (:td (:a :href (conc "file:" (pkg-file-location x system-name)) (str x)))))) (when (asdf:system-source-file named-system) (htm (:td (:a :href (conc "file:" (namestring (asdf:system-source-file named-system))) (str (conc system-name ".asd"))))))) (:tr (:th "Exported Functions") (:td (str (write-to-string total-functions))) (:th "Documented ") (:td (str (write-to-string documented-functions))) (:th "Undocumented") (:td (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 (with-html-output-to-string (*standard-output*) (:htm (:h1 (str system-name)) (package-overview system-name named-system) (:div (:h2 "Description") (str (ignore-errors (asdf:system-description named-system)))) (:div (:h2 "Exported Functions") (loop for x in (get-external-functions system-name) do (htm (:a :href (conc "display-function?name=" x) (str x)) (:br)))))))))OK. Now let's add dependencies to our description page for packages. This will require a few more helper functions. Looking at these helper functions, the ensure-list and flatten functions were borrowed from Alexandria and the effective-dependencies functions were borrowed from Leslie Polzer. The gridify1 function is a relatively straightforward loop to build out a table grid of x columns and adding empty html cells to the end in order to even things out.
(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 fromhttp://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 astring) with |col| columns. Obviously this requires that the calling functionhas 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))) (empty-cell '("" "")) (empty-list (list))) (with-html-output-to-string (var nil) (dotimes (i extra-cells) (push empty-cell empty-list)) (htm (:tbody (loop for xp on (append x empty-list) by (lambda (p) (nthcdr col p)) do (htm (:tr (loop for i upto (1- col) for package-name in xp do (htm (:td (:a :href (format nil "~a~a" base-parameter (string-downcase package-name)) (str (string-downcase package-name)) name))))))))))))So given these helpers, we can add another some area to the "display-package" function.
(:div (:h2 "Depends on") (let* ((dependency-list (effective-dependencies (read-from-string system-name)))) (htm (:table (str (gridify1 dependency-list "display-package?name="))))))We've been looking at the package side of things for awhile. Let's go back to the display-function page and consider what would be interesting here. SBCL has a function in sb-introspect called "who-calls", which can tell us what other currently loaded functions call the currently displayed function. So let's use that to create a list of links to functions which call the displayed function.
Often, function A will call function B several times. Since we don't want to clog the screen with the same function link multiple times, we will just create a list of calling functions and push a new function on that list only if it is not already a member. The entire display-function code now looks like this.
Note that at the moment we are sorting the calling functions in alphabetical order by name. You might choose to sort them by package or file location.
Now that we are getting display-function a bit more filled out, it is getting too long for my taste, so I'm going to break it into a page-macro, a couple of html-snippet functions and a sorting helper function.
(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)))))))) (with-html-output-to-string (*standard-output*) (htm (:h2 "Package: " (:a :href (conc "display-package?name=" package-name) (str package-name))) (:h2 (str name)) (:h3 "Documentation String") (str (documentation (read-from-string name) 'function)) (:br) (:h3 "Source File") (if file-pathname (htm (:a :href (conc "file:" file-pathname) (str name))) (htm (str "No file-pathname found!"))) (:h3 "Functions that call this function") (calling-functions name)))) (with-html-output-to-string (*standard-output*) (htm (:h2 (str (conc "Unknown function: " name)))))))(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 (htm (:a :href (conc "file:" caller-pathname) (str (car x))) (:br))))))))