Skip to content

Instantly share code, notes, and snippets.

@bhyde

bhyde/ql-tools.lisp

Last active April 26, 2016 15:08
Show Gist options
  • Save bhyde/5896565 to your computer and use it in GitHub Desktop.
Save bhyde/5896565 to your computer and use it in GitHub Desktop.
Download ZIP
A few things for playing with quicklisp metadata. Note that this reveals assorted things that make life interesting; so use 'em in a clean discardable session. Probably ccl only.
Raw
ql-tools.lisp
(in-package #:cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload "cl-ppcre")
(ql:quickload "optima")
(ql:quickload "optima.ppcre")
(use-package '#:optima)
(use-package '#:optima.ppcre))
(defun ensure-all-system-are-downloaded ()
"Download and unpack the tar files of all distributions."
(map nil #'ql-dist:ensure-installed (ql:system-list)))
(defmacro ignore-errors-but-trace (me &body body)
`(handler-case (progn ,@body)
(error (e) (format *error-output* "~&Error(~A): ~A" ,me e)))
#+nil
`(flet ((thunk () ,@body))
(block :ignore
(handler-bind
((error #'(lambda (e)
(format *error-output* "~&Error: ~A" e)
(return-from :ignore nil))))
(funcall #'thunk)))))
(defparameter *systems-to-ignore*
'("cl-fuse" ;; don't recall why this got on this list.
"cl-v4l2" ;; don't recall why this got on this list.
;; gsll is impossible without other stuff installed
"gsll"
;; teepeedee2 loads obsolete and troublesome versions of alexandria and trival-garbage
"teepeedee2"
))
(defvar *current-for-debug*)
(defun map-over-ql-system-definitions (ql-systems function)
"QL-systems is a list of ql-dist:system objects. The function is invoked on the
asdf define-system form of each of the one. This is done via find-system (so all
kinds of side effects are possible), and a bit of hackery using advise. Everything
is wrapeed in ignore-errors-but-trace."
(asdf/find-system:clear-defined-systems) ;; bang!
(macrolet ((with-advice ((function-name advice &rest details) &body body)
`(unwind-protect
(progn
(advise ,function-name ,advice ,@details)
,@body)
(unadvise ,function-name))))
(with-advice (asdf/defsystem:register-system-definition
(funcall function arglist)
:when :before)
(loop
for *current-for-debug* in ql-systems
as system-name = (or (ignore-errors-but-trace "ql-dist:name"
(ql-dist::name *current-for-debug*))
(continue))
unless (member system-name *systems-to-ignore* :test #'string=)
do
#+nil (format *error-output* "~&-- ~A --" system-name)
(let ((p *package*))
(ignore-errors-but-trace "asdf:find-system"
(asdf:find-system system-name))
(unless (eq p *package*)
(format *error-output* "~&DAMN: ~A changed package to ~A" system-name *package*)))
))))
(defmacro do-ql-systems ((def ql-systems) &body body)
"Convinence wrapper for map-over-asdf-system-definitions."
`(map-over-ql-system-definitions ,ql-systems #'(lambda (,def) ,@body)))
(defun ql-system-of-name (name)
(find name (ql:system-list) :key 'ql-dist:name :test #'string=))
(defparameter zzz
(loop with zzz = '("big-string"
"cl-css"
"cl-curlex"
"enchant" ; akd "cl-enchant"
"cl-geoip"
"cl-performance-tuning-helper"
"tcod" ; aka "cl-tcod"
"cl-template"
"clache"
"clinch"
"clite"
"clobber"
"delorean"
"generators"
"gettext"
"inner-conditional"
"lowlight"
"new-op"
"petit.package-utils"
"policy-cond"
"pretty-function"
"rectangle-packing"
"stmx"
"track-best"
"treedb"
"utilities.print-items"
"weblocks-stores"
"weblocks-utils")
for n in zzz
as s = (ql-system-of-name n)
unless s do (format t "~&Error: ~a not found." n)
when s collect s))
(defun properties-in-systems (&optional (ql-systems (ql:system-list)))
"Find out what properties people are using."
(ensure-all-system-are-downloaded)
(let ((count 0)
(result ()))
(do-ql-systems (system-definition ql-systems)
(incf count)
(ignore-errors-but-trace "study system"
(loop
with (nil . details) = system-definition
for (key nil) on details by #'cddr
do (incf (getf result key 0)))))
(values count result)))
;; > (properties-in-systems)
;; ... much noise ..
;; 2190
;; (:long-name 1 :test-system 1 :test-name 3 :package-name 8 :weakly-depends-on 1
;; :encoding 44 :default-component-class 47 :around-compile 4 :pathname 73
;; :systems-required 21 :class 117 :maintainer 422 :in-order-to 110
;; :defsystem-depends-on 18 :license 394 :perform 67 :properties 48 :long-description 213
;; :licence 981 :version 971 :name 451 :author 1433 :serial 509 :components 2167
;; :depends-on 1859 :description 1548)
(defun ql-system-of-designation (system-designation)
(typecase system-designation
(ql-dist:system system-designation)
(t (ql-system-of-name
(asdf:component-name
(asdf:find-system system-designation))))))
(defun defsystem-of-system (system-designation)
(block nil
(do-ql-systems (def (list (ql-system-of-designation system-designation)))
(return def))))
(defun get-source-of-system (system-name)
(let ((pathname (probe-file (format nil "/Users/bhyde/w/quicklisp-projects/~a/source.txt" system-name))))
(when pathname
(ematch (cl-ppcre:split " " (with-open-file (s pathname) (read-line s)))
((list kind url)
(list (intern (string-upcase kind) (symbol-package :key))
url))
((list kind url param)
(list (intern (string-upcase kind) (symbol-package :key))
url
param))))))
(defun get-assorted-urls (system-name)
(ematch (get-source-of-system system-name)
(nil nil)
((list :git (and url (ppcre "^git://github([-/.\\w]+).git$" x)))
(list :git
url
(concatenate 'string "https://github" x "#readme")))
((list :git (and url (ppcre "^git://([-/.\\w]+).git/$" _)))
(list :git url nil))
((list :git (and url (ppcre "^http://([-/.\\w]+).git/$" _)))
(list :git url nil))
((list :git (and url (ppcre "^git://common-lisp.net(/[-/.\\w]+)/[-.\\w]+.git$" x)))
(list :git url (concatenate 'string "http://common-lisp.net"
(cl-ppcre:regex-replace "projects" x "project"))))
((list :mercurial (and url (ppcre "^https://bitbucket.org" _)))
(list :mercurial url url))
((list :mercurial url)
(list :mercurial url nil))
((list :branched-git url _)
(list :branched-git url nil #+nil branch))))
(defun summarize-a-system (system-designation)
"Note hand editting the output before posting is advised."
(let* ((qs (ql-system-of-designation system-designation))
(ds (defsystem-of-system qs))
(system-name (first ds))
(props (rest ds)))
(destructuring-bind (&key license licence description long-description author maintainer &allow-other-keys) props
(format t "~2&~A -- ~A~& ~A"
system-name (or license licence "No license specified?")
(or long-description description "No description provided."))
(when (and author
(< (length author) 50))
(format t "~& author: ~A" author))
(when (and maintainer
(not (equal author maintainer))
(< (length maintainer) 37))
(format t "~& maintained by: ~A" maintainer))
(match (get-assorted-urls system-name)
((list kind src readme?)
(format t "~& ~a: ~A" kind src)
(when readme?
(format t "~& more: <a href=\"~A\">~A</a>" readme? readme?)))))))
(defun summarize-zzz ()
"Note hand editting the output before posting is advised."
(loop
initially (format t "~&<pre>")
finally (format t "~&</pre>")
for qs in zzz
do (summarize-a-system qs)))
Raw
summarize-zzz.txt
<pre>
big-string -- BSD 3-clause (see LICENSE)
Big strings, similar to Java's StringBuilder.
author: Robert Smith <[email protected]>
mercurial: https://bitbucket.org/tarballs_are_good/big-string
more: <a href="https://bitbucket.org/tarballs_are_good/big-string">https://bitbucket.org/tarballs_are_good/big-string</a>
cl-css -- MIT-style
Simple inline CSS generator
author: [email protected]
git: git://github.com/Inaimathi/cl-css.git
more: <a href="https://github.com/Inaimathi/cl-css#readme">https://github.com/Inaimathi/cl-css#readme</a>
cl-curlex -- GPL
Leak *LEXENV* variable from compilation into runtime
author: Alexander Popolitov <[email protected]>
git: git://github.com/mabragor/cl-curlex.git
more: <a href="https://github.com/mabragor/cl-curlex#readme">https://github.com/mabragor/cl-curlex#readme</a>
enchant -- Public Domain
Bindings for Enchant spell-checker library
author: Teemu Likonen <[email protected]>
cl-geoip -- WTFPL 2.0
Wrapper around libGeoIP
git: git://github.com/dasuxullebt/cl-geoip.git
more: <a href="https://github.com/dasuxullebt/cl-geoip#readme">https://github.com/dasuxullebt/cl-geoip#readme</a>
cl-performance-tuning-helper -- MIT
A simple performance tuning helper tool box for Common Lisp
author: SUZUKI Shingo
git: git://github.com/ichimal/cl-performance-tuning-helper.git
more: <a href="https://github.com/ichimal/cl-performance-tuning-helper#readme">https://github.com/ichimal/cl-performance-tuning-helper#readme</a>
tcod -- No license specified?
Common Lisp bindings for libtcod, a truecolour
terminal-emulation library written in C.
author: Paul Sexton <[email protected]>
cl-template -- MIT
A simple output-agnostic templating system for Common Lisp.
author: Peter Cannici <[email protected]>
git: git://github.com/alpha123/cl-template.git
more: <a href="https://github.com/alpha123/cl-template#readme">https://github.com/alpha123/cl-template#readme</a>
clache -- LLGPL
No description provided.
author: Tomohiro Matsuyama
git: git://github.com/html/clache.git
more: <a href="https://github.com/html/clache#readme">https://github.com/html/clache#readme</a>
clinch -- BSD
Describe CLinch here
author: Brad Beer (WarWeasle)
git: git://github.com/BradWBeer/CLinch.git
more: <a href="https://github.com/BradWBeer/CLinch#readme">https://github.com/BradWBeer/CLinch#readme</a>
clite -- ISC
Lite weight testing framework
author: Andreas Wild <[email protected]>
git: git://github.com/lispy-stuff/clite.git
more: <a href="https://github.com/lispy-stuff/clite#readme">https://github.com/lispy-stuff/clite#readme</a>
clobber -- No license specified?
No description provided.
git: git://github.com/robert-strandh/Clobber.git
more: <a href="https://github.com/robert-strandh/Clobber#readme">https://github.com/robert-strandh/Clobber#readme</a>
delorean -- No license specified?
Delorean is a time machine for unit tests
author: Andy Chambers
git: git://github.com/cddr/delorean.git
more: <a href="https://github.com/cddr/delorean#readme">https://github.com/cddr/delorean#readme</a>
generators -- BSD
A common lisp package providing python style generators based
on delimited continuations
author: <[email protected]>
git: git://github.com/AccelerationNet/generators.git
more: <a href="https://github.com/AccelerationNet/generators#readme">https://github.com/AccelerationNet/generators#readme</a>
gettext -- GNU Lesser General Public Licence 3.0
A port of gettext runtime to Common Lisp
author: Thomas Bakketun <[email protected]>
git: git://github.com/copyleft/gettext.git
more: <a href="https://github.com/copyleft/gettext#readme">https://github.com/copyleft/gettext#readme</a>
inner-conditional -- LLGPL
Series of macros which optimizes out the inner conditional jumping
author: Masataro Asai
git: git://github.com/guicho271828/inner-conditional.git
more: <a href="https://github.com/guicho271828/inner-conditional#readme">https://github.com/guicho271828/inner-conditional#readme</a>
lowlight -- MIT
A simple and flexible syntax highlighter
author: Christoph Finkensiep <[email protected]>
git: git://github.com/chfin/lowlight.git
more: <a href="https://github.com/chfin/lowlight#readme">https://github.com/chfin/lowlight#readme</a>
new-op -- No license specified?
No description provided.
git: git://common-lisp.net/projects/new-op/new-op.git
more: <a href="http://common-lisp.net/project/new-op">http://common-lisp.net/project/new-op</a>
petit.package-utils -- MIT
petit tool box for packaging
author: SUZUKI Shingo
git: git://github.com/ichimal/petit.package-utils.git
more: <a href="https://github.com/ichimal/petit.package-utils#readme">https://github.com/ichimal/petit.package-utils#readme</a>
policy-cond -- Public Domain
A macro to insert code based on compiler policy.
author: Robert Smith <[email protected]>
mercurial: https://bitbucket.org/tarballs_are_good/policy-cond
more: <a href="https://bitbucket.org/tarballs_are_good/policy-cond">https://bitbucket.org/tarballs_are_good/policy-cond</a>
pretty-function -- No license specified?
No description provided.
git: git://github.com/nallen05/pretty-function.git
more: <a href="https://github.com/nallen05/pretty-function#readme">https://github.com/nallen05/pretty-function#readme</a>
rectangle-packing -- LLGPL, but I am flexible, ask me if you want something else.
Code to pack rectangles into a bigger rectangle. Useful for texture packing for OpenGL.
author: Willem Rein Oudshoorn <[email protected]>
git: git://github.com/woudshoo/rectangle-packing.git
more: <a href="https://github.com/woudshoo/rectangle-packing#readme">https://github.com/woudshoo/rectangle-packing#readme</a>
stmx -- LLGPL
Composable Software Transactional Memory
author: Massimiliano Ghilardi
branched-git: git://github.com/cosmos72/stmx.git
track-best -- Free
Macros/functions for tracking the best items. See the README.md for more details.
author: Patrick Stein <[email protected]>
git: http://git.nklein.com/lisp/libs/track-best.git/
treedb -- MIT
A hierarchical key-value-database
author: Christoph Finkensiep <[email protected]>
git: git://github.com/chfin/treedb.git
more: <a href="https://github.com/chfin/treedb#readme">https://github.com/chfin/treedb#readme</a>
utilities.print-items -- LLGPLv3; see COPYING file for details.
This system provides some generic condition classes in
conjunction with support functions and macros.
author: Jan Moringen <[email protected]>
git: git://github.com/scymtym/utilities.print-items.git
more: <a href="https://github.com/scymtym/utilities.print-items#readme">https://github.com/scymtym/utilities.print-items#readme</a>
weblocks-stores -- LLGPL
A base for weblocks stores
author: Olexiy Zamkoviy
maintained by: Olexiy Zamkoviy, Scott L. Burson
git: git://github.com/html/weblocks-stores.git
more: <a href="https://github.com/html/weblocks-stores#readme">https://github.com/html/weblocks-stores#readme</a>
weblocks-utils -- Public Domain
Utils for weblocks framework
author: Olexiy Zamkoviy
git: git://github.com/html/weblocks-utils.git
more: <a href="https://github.com/html/weblocks-utils#readme">https://github.com/html/weblocks-utils#readme</a>
</pre>
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment