Vim window logic, slimv
This commit is contained in:
Ian Keane
parent
babcc9e44b
commit
515847d07e
791 changed files with 51552 additions and 86 deletions
|
|
@ -1,6 +1,6 @@
|
|||
db_file "~/.config/mpd/database"
|
||||
log_file "~/.config/mpd/log"
|
||||
music_directory "~/Music"
|
||||
music_directory "/mnt/media/music"
|
||||
playlist_directory "~/.config/mpd/playlists"
|
||||
pid_file "~/.config/mpd/pid"
|
||||
state_file "~/.config/mpd/state"
|
||||
|
|
|
|||
1
ranger/rc.conf
Normal file
1
ranger/rc.conf
Normal file
|
|
@ -0,0 +1 @@
|
|||
map bw shell wal -i %s
|
||||
264
ranger/rifle.conf
Normal file
264
ranger/rifle.conf
Normal file
|
|
@ -0,0 +1,264 @@
|
|||
# vim: ft=cfg
|
||||
#
|
||||
# This is the configuration file of "rifle", ranger's file executor/opener.
|
||||
# Each line consists of conditions and a command. For each line the conditions
|
||||
# are checked and if they are met, the respective command is run.
|
||||
#
|
||||
# Syntax:
|
||||
# <condition1> , <condition2> , ... = command
|
||||
#
|
||||
# The command can contain these environment variables:
|
||||
# $1-$9 | The n-th selected file
|
||||
# $@ | All selected files
|
||||
#
|
||||
# If you use the special command "ask", rifle will ask you what program to run.
|
||||
#
|
||||
# Prefixing a condition with "!" will negate its result.
|
||||
# These conditions are currently supported:
|
||||
# match <regexp> | The regexp matches $1
|
||||
# ext <regexp> | The regexp matches the extension of $1
|
||||
# mime <regexp> | The regexp matches the mime type of $1
|
||||
# name <regexp> | The regexp matches the basename of $1
|
||||
# path <regexp> | The regexp matches the absolute path of $1
|
||||
# has <program> | The program is installed (i.e. located in $PATH)
|
||||
# env <variable> | The environment variable "variable" is non-empty
|
||||
# file | $1 is a file
|
||||
# directory | $1 is a directory
|
||||
# number <n> | change the number of this command to n
|
||||
# terminal | stdin, stderr and stdout are connected to a terminal
|
||||
# X | $DISPLAY is not empty (i.e. Xorg runs)
|
||||
#
|
||||
# There are also pseudo-conditions which have a "side effect":
|
||||
# flag <flags> | Change how the program is run. See below.
|
||||
# label <label> | Assign a label or name to the command so it can
|
||||
# | be started with :open_with <label> in ranger
|
||||
# | or `rifle -p <label>` in the standalone executable.
|
||||
# else | Always true.
|
||||
#
|
||||
# Flags are single characters which slightly transform the command:
|
||||
# f | Fork the program, make it run in the background.
|
||||
# | New command = setsid $command >& /dev/null &
|
||||
# r | Execute the command with root permissions
|
||||
# | New command = sudo $command
|
||||
# t | Run the program in a new terminal. If $TERMCMD is not defined,
|
||||
# | rifle will attempt to extract it from $TERM.
|
||||
# | New command = $TERMCMD -e $command
|
||||
# Note: The "New command" serves only as an illustration, the exact
|
||||
# implementation may differ.
|
||||
# Note: When using rifle in ranger, there is an additional flag "c" for
|
||||
# only running the current file even if you have marked multiple files.
|
||||
|
||||
#-------------------------------------------
|
||||
# Websites
|
||||
#-------------------------------------------
|
||||
# Rarely installed browsers get higher priority; It is assumed that if you
|
||||
# install a rare browser, you probably use it. Firefox/konqueror/w3m on the
|
||||
# other hand are often only installed as fallback browsers.
|
||||
ext x?html?, has surf, X, flag f = surf -- file://"$1"
|
||||
ext x?html?, has vimprobable, X, flag f = vimprobable -- "$@"
|
||||
ext x?html?, has vimprobable2, X, flag f = vimprobable2 -- "$@"
|
||||
ext x?html?, has qutebrowser, X, flag f = qutebrowser -- "$@"
|
||||
ext x?html?, has dwb, X, flag f = dwb -- "$@"
|
||||
ext x?html?, has jumanji, X, flag f = jumanji -- "$@"
|
||||
ext x?html?, has luakit, X, flag f = luakit -- "$@"
|
||||
ext x?html?, has uzbl, X, flag f = uzbl -- "$@"
|
||||
ext x?html?, has uzbl-tabbed, X, flag f = uzbl-tabbed -- "$@"
|
||||
ext x?html?, has uzbl-browser, X, flag f = uzbl-browser -- "$@"
|
||||
ext x?html?, has uzbl-core, X, flag f = uzbl-core -- "$@"
|
||||
ext x?html?, has midori, X, flag f = midori -- "$@"
|
||||
ext x?html?, has chromium-browser, X, flag f = chromium-browser -- "$@"
|
||||
ext x?html?, has chromium, X, flag f = chromium -- "$@"
|
||||
ext x?html?, has google-chrome, X, flag f = google-chrome -- "$@"
|
||||
ext x?html?, has opera, X, flag f = opera -- "$@"
|
||||
ext x?html?, has firefox, X, flag f = firefox -- "$@"
|
||||
ext x?html?, has seamonkey, X, flag f = seamonkey -- "$@"
|
||||
ext x?html?, has iceweasel, X, flag f = iceweasel -- "$@"
|
||||
ext x?html?, has epiphany, X, flag f = epiphany -- "$@"
|
||||
ext x?html?, has konqueror, X, flag f = konqueror -- "$@"
|
||||
ext x?html?, has elinks, terminal = elinks "$@"
|
||||
ext x?html?, has links2, terminal = links2 "$@"
|
||||
ext x?html?, has links, terminal = links "$@"
|
||||
ext x?html?, has lynx, terminal = lynx -- "$@"
|
||||
ext x?html?, has w3m, terminal = w3m "$@"
|
||||
|
||||
#-------------------------------------------
|
||||
# Spreadsheets
|
||||
#-------------------------------------------
|
||||
ext csv = sc-im "$@"
|
||||
ext xls = sc-im "$@"
|
||||
ext xlsx = sc-im "$1"
|
||||
|
||||
#-------------------------------------------
|
||||
# Misc
|
||||
#-------------------------------------------
|
||||
# Define the "editor" for text files as first action
|
||||
mime ^text, label editor = ${VISUAL:-$EDITOR} -- "$@"
|
||||
mime ^text, label pager = "$PAGER" -- "$@"
|
||||
!mime ^text, label editor, ext xml|json|tex|py|pl|rb|js|sh|php = ${VISUAL:-$EDITOR} -- "$@"
|
||||
!mime ^text, label pager, ext xml|json|tex|py|pl|rb|js|sh|php = "$PAGER" -- "$@"
|
||||
|
||||
ext 1 = man "$1"
|
||||
ext s[wmf]c, has zsnes, X = zsnes "$1"
|
||||
ext s[wmf]c, has snes9x-gtk,X = snes9x-gtk "$1"
|
||||
ext nes, has fceux, X = fceux "$1"
|
||||
ext exe = wine "$1"
|
||||
name ^[mM]akefile$ = make
|
||||
|
||||
|
||||
#--------------------------------------------
|
||||
# Code
|
||||
#-------------------------------------------
|
||||
ext py = python -- "$1"
|
||||
ext pl = perl -- "$1"
|
||||
ext rb = ruby -- "$1"
|
||||
ext js = node -- "$1"
|
||||
ext sh = sh -- "$1"
|
||||
ext php = php -- "$1"
|
||||
|
||||
#--------------------------------------------
|
||||
# Audio without X
|
||||
#-------------------------------------------
|
||||
mime ^audio|ogg$, terminal, has mpv = mpv -- "$@"
|
||||
mime ^audio|ogg$, terminal, has mplayer2 = mplayer2 -- "$@"
|
||||
mime ^audio|ogg$, terminal, has mplayer = mplayer -- "$@"
|
||||
ext midi?, terminal, has wildmidi = wildmidi -- "$@"
|
||||
|
||||
#--------------------------------------------
|
||||
# Video/Audio with a GUI
|
||||
#-------------------------------------------
|
||||
mime ^video|audio, has gmplayer, X, flag f = gmplayer -- "$@"
|
||||
mime ^video|audio, has smplayer, X, flag f = smplayer "$@"
|
||||
mime ^video, has mpv, X, flag f = mpv -- "$@"
|
||||
mime ^video, has mpv, X, flag f = mpv --fs -- "$@"
|
||||
mime ^video, has mplayer2, X, flag f = mplayer2 -- "$@"
|
||||
mime ^video, has mplayer2, X, flag f = mplayer2 -fs -- "$@"
|
||||
mime ^video, has mplayer, X, flag f = mplayer -- "$@"
|
||||
mime ^video, has mplayer, X, flag f = mplayer -fs -- "$@"
|
||||
mime ^video|audio, has vlc, X, flag f = vlc -- "$@"
|
||||
mime ^video|audio, has totem, X, flag f = totem -- "$@"
|
||||
mime ^video|audio, has totem, X, flag f = totem --fullscreen -- "$@"
|
||||
|
||||
#--------------------------------------------
|
||||
# Video without X:
|
||||
#-------------------------------------------
|
||||
mime ^video, terminal, !X, has mpv = mpv -- "$@"
|
||||
mime ^video, terminal, !X, has mplayer2 = mplayer2 -- "$@"
|
||||
mime ^video, terminal, !X, has mplayer = mplayer -- "$@"
|
||||
|
||||
#-------------------------------------------
|
||||
# Documents
|
||||
#-------------------------------------------
|
||||
ext pdf, has llpp, X, flag f = llpp "$@"
|
||||
ext pdf, has zathura, X, flag f = zathura -- "$@"
|
||||
ext pdf, has mupdf, X, flag f = mupdf "$@"
|
||||
ext pdf, has mupdf-x11,X, flag f = mupdf-x11 "$@"
|
||||
ext pdf, has apvlv, X, flag f = apvlv -- "$@"
|
||||
ext pdf, has xpdf, X, flag f = xpdf -- "$@"
|
||||
ext pdf, has evince, X, flag f = evince -- "$@"
|
||||
ext pdf, has atril, X, flag f = atril -- "$@"
|
||||
ext pdf, has okular, X, flag f = okular -- "$@"
|
||||
ext pdf, has epdfview, X, flag f = epdfview -- "$@"
|
||||
ext pdf, has qpdfview, X, flag f = qpdfview "$@"
|
||||
ext pdf, has open, X, flag f = open "$@"
|
||||
|
||||
ext docx?, has catdoc, terminal = catdoc -- "$@" | "$PAGER"
|
||||
|
||||
ext sxc|xlsx?|xlt|xlw|gnm|gnumeric, has gnumeric, X, flag f = gnumeric -- "$@"
|
||||
ext sxc|xlsx?|xlt|xlw|gnm|gnumeric, has kspread, X, flag f = kspread -- "$@"
|
||||
ext pptx?|od[dfgpst]|docx?|sxc|xlsx?|xlt|xlw|gnm|gnumeric, has libreoffice, X, flag f = libreoffice "$@"
|
||||
ext pptx?|od[dfgpst]|docx?|sxc|xlsx?|xlt|xlw|gnm|gnumeric, has soffice, X, flag f = soffice "$@"
|
||||
ext pptx?|od[dfgpst]|docx?|sxc|xlsx?|xlt|xlw|gnm|gnumeric, has ooffice, X, flag f = ooffice "$@"
|
||||
|
||||
ext djvu, has zathura,X, flag f = zathura -- "$@"
|
||||
ext djvu, has evince, X, flag f = evince -- "$@"
|
||||
ext djvu, has atril, X, flag f = atril -- "$@"
|
||||
ext djvu, has djview, X, flag f = djview -- "$@"
|
||||
|
||||
ext epub, has ebook-viewer, X, flag f = ebook-viewer -- "$@"
|
||||
ext mobi, has ebook-viewer, X, flag f = ebook-viewer -- "$@"
|
||||
|
||||
#-------------------------------------------
|
||||
# Image Viewing:
|
||||
#-------------------------------------------
|
||||
mime ^image/svg, has inkscape, X, flag f = inkscape -- "$@"
|
||||
mime ^image/svg, has display, X, flag f = display -- "$@"
|
||||
|
||||
mime ^image, has pqiv, X, flag f = pqiv -- "$@"
|
||||
mime ^image, has sxiv, X, flag f = sxiv -- "$@"
|
||||
mime ^image, has feh, X, flag f = feh -- "$@"
|
||||
mime ^image, has mirage, X, flag f = mirage -- "$@"
|
||||
mime ^image, has ristretto, X, flag f = ristretto "$@"
|
||||
mime ^image, has eog, X, flag f = eog -- "$@"
|
||||
mime ^image, has eom, X, flag f = eom -- "$@"
|
||||
mime ^image, has nomacs, X, flag f = nomacs -- "$@"
|
||||
mime ^image, has geeqie, X, flag f = geeqie -- "$@"
|
||||
mime ^image, has gwenview, X, flag f = gwenview -- "$@"
|
||||
mime ^image, has gimp, X, flag f = gimp -- "$@"
|
||||
ext xcf, X, flag f = gimp -- "$@"
|
||||
|
||||
#-------------------------------------------
|
||||
# Archives
|
||||
#-------------------------------------------
|
||||
|
||||
# avoid password prompt by providing empty password
|
||||
ext 7z, has 7z = 7z -p l "$@" | "$PAGER"
|
||||
# This requires atool
|
||||
ext ace|ar|arc|bz2?|cab|cpio|cpt|deb|dgc|dmg|gz, has atool = atool --list --each -- "$@" | "$PAGER"
|
||||
ext iso|jar|msi|pkg|rar|shar|tar|tgz|xar|xpi|xz|zip, has atool = atool --list --each -- "$@" | "$PAGER"
|
||||
ext 7z|ace|ar|arc|bz2?|cab|cpio|cpt|deb|dgc|dmg|gz, has atool = atool --extract --each -- "$@"
|
||||
ext iso|jar|msi|pkg|rar|shar|tar|tgz|xar|xpi|xz|zip, has atool = atool --extract --each -- "$@"
|
||||
|
||||
# Listing and extracting archives without atool:
|
||||
ext tar|gz|bz2|xz, has tar = tar vvtf "$1" | "$PAGER"
|
||||
ext tar|gz|bz2|xz, has tar = for file in "$@"; do tar vvxf "$file"; done
|
||||
ext bz2, has bzip2 = for file in "$@"; do bzip2 -dk "$file"; done
|
||||
ext zip, has unzip = unzip -l "$1" | less
|
||||
ext zip, has unzip = for file in "$@"; do unzip -d "${file%.*}" "$file"; done
|
||||
ext ace, has unace = unace l "$1" | less
|
||||
ext ace, has unace = for file in "$@"; do unace e "$file"; done
|
||||
ext rar, has unrar = unrar l "$1" | less
|
||||
ext rar, has unrar = for file in "$@"; do unrar x "$file"; done
|
||||
|
||||
#-------------------------------------------
|
||||
# Flag t fallback terminals
|
||||
#-------------------------------------------
|
||||
# Rarely installed terminal emulators get higher priority; It is assumed that
|
||||
# if you install a rare terminal emulator, you probably use it.
|
||||
# gnome-terminal/konsole/xterm on the other hand are often installed as part of
|
||||
# a desktop environment or as fallback terminal emulators.
|
||||
mime ^ranger/x-terminal-emulator, has terminology = terminology -e "$@"
|
||||
mime ^ranger/x-terminal-emulator, has kitty = kitty -- "$@"
|
||||
mime ^ranger/x-terminal-emulator, has alacritty = alacritty -e "$@"
|
||||
mime ^ranger/x-terminal-emulator, has sakura = sakura -e "$@"
|
||||
mime ^ranger/x-terminal-emulator, has lilyterm = lilyterm -e "$@"
|
||||
#mime ^ranger/x-terminal-emulator, has cool-retro-term = cool-retro-term -e "$@"
|
||||
mime ^ranger/x-terminal-emulator, has termite = termite -x '"$@"'
|
||||
#mime ^ranger/x-terminal-emulator, has yakuake = yakuake -e "$@"
|
||||
mime ^ranger/x-terminal-emulator, has guake = guake -ne "$@"
|
||||
mime ^ranger/x-terminal-emulator, has tilda = tilda -c "$@"
|
||||
mime ^ranger/x-terminal-emulator, has st = st -e "$@"
|
||||
mime ^ranger/x-terminal-emulator, has terminator = terminator -x "$@"
|
||||
mime ^ranger/x-terminal-emulator, has urxvt = urxvt -e "$@"
|
||||
mime ^ranger/x-terminal-emulator, has pantheon-terminal = pantheon-terminal -e "$@"
|
||||
mime ^ranger/x-terminal-emulator, has lxterminal = lxterminal -e "$@"
|
||||
mime ^ranger/x-terminal-emulator, has mate-terminal = mate-terminal -x "$@"
|
||||
mime ^ranger/x-terminal-emulator, has xfce4-terminal = xfce4-terminal -x "$@"
|
||||
mime ^ranger/x-terminal-emulator, has konsole = konsole -e "$@"
|
||||
mime ^ranger/x-terminal-emulator, has gnome-terminal = gnome-terminal -- "$@"
|
||||
mime ^ranger/x-terminal-emulator, has xterm = xterm -e "$@"
|
||||
|
||||
#-------------------------------------------
|
||||
# Misc
|
||||
#-------------------------------------------
|
||||
label wallpaper, number 11, mime ^image, has feh, X = feh --bg-scale "$1"
|
||||
label wallpaper, number 12, mime ^image, has feh, X = feh --bg-tile "$1"
|
||||
label wallpaper, number 13, mime ^image, has feh, X = feh --bg-center "$1"
|
||||
label wallpaper, number 14, mime ^image, has feh, X = feh --bg-fill "$1"
|
||||
|
||||
# Define the editor for non-text files + pager as last action
|
||||
!mime ^text, !ext xml|json|csv|tex|py|pl|rb|js|sh|php = ask
|
||||
label editor, !mime ^text, !ext xml|json|csv|tex|py|pl|rb|js|sh|php = ${VISUAL:-$EDITOR} -- "$@"
|
||||
label pager, !mime ^text, !ext xml|json|csv|tex|py|pl|rb|js|sh|php = "$PAGER" -- "$@"
|
||||
|
||||
# The very last action, so that it's never triggered accidentally, is to execute a program:
|
||||
mime application/x-executable = "$1"
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
BIN
sbcl/.quicklisp/dists/quicklisp/archives/cl-emb-20190521-git.tgz
Normal file
BIN
sbcl/.quicklisp/dists/quicklisp/archives/cl-emb-20190521-git.tgz
Normal file
Binary file not shown.
BIN
sbcl/.quicklisp/dists/quicklisp/archives/cl-fad-20190813-git.tgz
Normal file
BIN
sbcl/.quicklisp/dists/quicklisp/archives/cl-fad-20190813-git.tgz
Normal file
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
BIN
sbcl/.quicklisp/dists/quicklisp/archives/prove-20171130-git.tgz
Normal file
BIN
sbcl/.quicklisp/dists/quicklisp/archives/prove-20171130-git.tgz
Normal file
Binary file not shown.
BIN
sbcl/.quicklisp/dists/quicklisp/archives/quickproject-1.4.1.tgz
Normal file
BIN
sbcl/.quicklisp/dists/quicklisp/archives/quickproject-1.4.1.tgz
Normal file
Binary file not shown.
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/anaphora-20191007-git/
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-ansi-text-20150804-git/
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-colors-20180328-git/
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-emb-20190521-git/
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-fad-20190813-git/
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-ppcre-20190521-git/
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-project-20190521-git/
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/html-template-20171227-git/
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/let-plus-20191130-git/
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/local-time-20190710-git/
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/prove-20171130-git/
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/quickproject-1.4.1/
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/anaphora-20191007-git/anaphora.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-ansi-text-20150804-git/cl-ansi-text-test.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-ansi-text-20150804-git/cl-ansi-text.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-colors-20180328-git/cl-colors.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-emb-20190521-git/cl-emb.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-fad-20190813-git/cl-fad.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/local-time-20190710-git/cl-postgres+local-time.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-ppcre-20190521-git/cl-ppcre-unicode.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-ppcre-20190521-git/cl-ppcre.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-project-20190521-git/cl-project-test.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/cl-project-20190521-git/cl-project.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/prove-20171130-git/cl-test-more.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/html-template-20171227-git/html-template.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/let-plus-20191130-git/let-plus.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/local-time-20190710-git/local-time.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/prove-20171130-git/prove-asdf.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/prove-20171130-git/prove-test.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/prove-20171130-git/prove.asd
|
||||
|
|
@ -0,0 +1 @@
|
|||
dists/quicklisp/software/quickproject-1.4.1/quickproject.asd
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
language: lisp
|
||||
sudo: required
|
||||
|
||||
env:
|
||||
matrix:
|
||||
- LISP=abcl
|
||||
- LISP=allegro
|
||||
- LISP=sbcl
|
||||
- LISP=sbcl32
|
||||
- LISP=ccl
|
||||
- LISP=ccl32
|
||||
- LISP=ecl
|
||||
- LISP=clisp
|
||||
- LISP=clisp32
|
||||
- LISP=cmucl
|
||||
|
||||
matrix:
|
||||
allow_failures:
|
||||
# Disabled until issue #6 is fixed.
|
||||
- env: LISP=clisp
|
||||
- env: LISP=clisp32
|
||||
# Disabled until cim supports cmucl.
|
||||
- env: LISP=cmucl
|
||||
|
||||
install:
|
||||
- curl -L https://github.com/tokenrove/cl-travis/raw/master/install.sh | sh
|
||||
- if [ "${LISP:(-2)}" = "32" ]; then
|
||||
sudo apt-get install -qq -y libc6-dev-i386;
|
||||
fi
|
||||
|
||||
script:
|
||||
- cl -e '(ql:quickload :anaphora/test)
|
||||
(unless (asdf:oos :test-op :anaphora/test)
|
||||
(uiop:quit 1))'
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
;;;; This file is part of the Anaphora package Common Lisp,
|
||||
;;;; and has been placed in Public Domain by the author,
|
||||
;;;; Nikodemus Siivola <nikodemus@random-state.net>
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
# Anaphora
|
||||
|
||||
Anaphora is the anaphoric macro collection from Hell: it includes many
|
||||
new fiends in addition to old friends like `AIF` and `AWHEN`.
|
||||
Anaphora has been placed in Public Domain by the author, [Nikodemus
|
||||
Siivola](mailto:nikodemus@random-state.net).
|
||||
|
||||
# Installation
|
||||
|
||||
Use [quicklisp](http://www.quicklisp.org/), and simply:
|
||||
|
||||
```
|
||||
CL-USER(1): (ql:quickload "anaphora")
|
||||
```
|
||||
|
||||
# Documentation
|
||||
|
||||
Anaphoric macros provide implicit bindings for various
|
||||
operations. Extensive use of anaphoric macros is not good style,
|
||||
and probably makes you go blind as well — there's a reason why
|
||||
Anaphora claims to be from Hell.
|
||||
|
||||
Anaphora provides two families of anaphoric macros, which can be
|
||||
identified by their names and packages (both families are also
|
||||
exported from the package `ANAPHORA`). The implicitly-bound symbol
|
||||
`ANAPHORA:IT` is also exported from all three packages.
|
||||
|
||||
## Basic anaphora
|
||||
|
||||
#### Exported from package `ANAPHORA-BASIC`
|
||||
|
||||
These bind their first argument to `IT` via `LET`. In case of `COND`
|
||||
all clauses have their test-values bound to `IT`.
|
||||
|
||||
Variants: `AAND`, `ALET`, `APROG1`, `AIF`, `ACOND`, `AWHEN`, `ACASE`,
|
||||
`ACCASE`, `AECASE`, `ATYPECASE`, `ACTYPECASE`, and `AETYPECASE`.
|
||||
|
||||
## Symbol-macro anaphora
|
||||
|
||||
#### Exported from package `ANAPHORA-SYMBOL`
|
||||
|
||||
These bind their first argument (unevaluated) to `IT` via
|
||||
SYMBOL-`MACROLET.`
|
||||
|
||||
Variants: `SOR`, `SLET`, `SIF`, `SCOND`, `SUNLESS`,
|
||||
`SWHEN`, `SCASE`, `SCCASE`, `SECASE`, `STYPECASE`, `SCTYPECASE`,
|
||||
`SETYPECASE`.
|
||||
|
||||
Also: `ASIF`, which binds via `LET` for the
|
||||
then-clause, and `SYMBOL-MACROLET` for the else-clause.
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-lisp; -*-
|
||||
|
||||
;;;; Anaphora: The Anaphoric Macro Package from Hell
|
||||
;;;;
|
||||
;;;; This been placed in Public Domain by the author,
|
||||
;;;; Nikodemus Siivola <nikodemus@random-state.net>
|
||||
|
||||
(defsystem :anaphora
|
||||
:version "0.9.6"
|
||||
:description "The Anaphoric Macro Package from Hell"
|
||||
:author "Nikodemus Siivola <nikodemus@random-state.net>"
|
||||
:license "Public Domain"
|
||||
:components
|
||||
((:file "packages")
|
||||
(:file "early" :depends-on ("packages"))
|
||||
(:file "symbolic" :depends-on ("early"))
|
||||
(:file "anaphora" :depends-on ("symbolic"))))
|
||||
|
||||
(defsystem :anaphora/test
|
||||
:description "Tests for anaphora"
|
||||
:author "Nikodemus Siivola <nikodemus@random-state.net>"
|
||||
:license "Public Domain"
|
||||
:depends-on (:anaphora :rt)
|
||||
:components ((:file "tests")))
|
||||
|
||||
(defmethod perform ((o test-op) (c (eql (find-system :anaphora))))
|
||||
(test-system :anaphora/test))
|
||||
|
||||
(defmethod perform ((o test-op) (c (eql (find-system :anaphora/test))))
|
||||
(or (symbol-call :rt '#:do-tests)
|
||||
(error "test-op failed")))
|
||||
|
|
@ -0,0 +1,162 @@
|
|||
;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: ANAPHORA -*-
|
||||
|
||||
;;;; Anaphora: The Anaphoric Macro Package from Hell
|
||||
;;;;
|
||||
;;;; This been placed in Public Domain by the author,
|
||||
;;;; Nikodemus Siivola <nikodemus@random-state.net>
|
||||
|
||||
(in-package :anaphora)
|
||||
|
||||
;;; This was the original implementation of SYMBOLIC -- and still good
|
||||
;;; for getting the basic idea. Brian Masterbrooks solution to
|
||||
;;; infinite recusion during macroexpansion, that nested forms of this
|
||||
;;; are subject to, is in symbolic.lisp.
|
||||
;;;
|
||||
;;; (defmacro symbolic (op test &body body &environment env)
|
||||
;;; `(symbol-macrolet ((it ,test))
|
||||
;;; (,op it ,@body)))
|
||||
|
||||
(defmacro alet (form &body body)
|
||||
"Binds the FORM to IT (via LET) in the scope of the BODY."
|
||||
`(anaphoric ignore-first ,form (progn ,@body)))
|
||||
|
||||
(defmacro slet (form &body body)
|
||||
"Binds the FORM to IT (via SYMBOL-MACROLET) in the scope of the BODY. IT can
|
||||
be set with SETF."
|
||||
`(symbolic ignore-first ,form (progn ,@body)))
|
||||
|
||||
(defmacro aand (first &rest rest)
|
||||
"Like AND, except binds the first argument to IT (via LET) for the
|
||||
scope of the rest of the arguments."
|
||||
`(anaphoric and ,first ,@rest))
|
||||
|
||||
(defmacro sor (first &rest rest)
|
||||
"Like OR, except binds the first argument to IT (via SYMBOL-MACROLET) for
|
||||
the scope of the rest of the arguments. IT can be set with SETF."
|
||||
`(symbolic or ,first ,@rest))
|
||||
|
||||
(defmacro aif (test then &optional else)
|
||||
"Like IF, except binds the result of the test to IT (via LET) for
|
||||
the scope of the then and else expressions."
|
||||
`(anaphoric if ,test ,then ,else))
|
||||
|
||||
(defmacro sif (test then &optional else)
|
||||
"Like IF, except binds the test form to IT (via SYMBOL-MACROLET) for
|
||||
the scope of the then and else expressions. IT can be set with SETF"
|
||||
`(symbolic if ,test ,then ,else))
|
||||
|
||||
(defmacro asif (test then &optional else)
|
||||
"Like IF, except binds the result of the test to IT (via LET) for
|
||||
the the scope of the then-expression, and the test form to IT (via
|
||||
SYMBOL-MACROLET) for the scope of the else-expression. Within scope of
|
||||
the else-expression, IT can be set with SETF."
|
||||
`(let ((it ,test))
|
||||
(if it
|
||||
,then
|
||||
(symbolic ignore-first ,test ,else))))
|
||||
|
||||
(defmacro aprog1 (first &body rest)
|
||||
"Binds IT to the first form so that it can be used in the rest of the
|
||||
forms. The whole thing returns IT."
|
||||
`(anaphoric prog1 ,first ,@rest))
|
||||
|
||||
(defmacro awhen (test &body body)
|
||||
"Like WHEN, except binds the result of the test to IT (via LET) for the scope
|
||||
of the body."
|
||||
`(anaphoric when ,test ,@body))
|
||||
|
||||
(defmacro swhen (test &body body)
|
||||
"Like WHEN, except binds the test form to IT (via SYMBOL-MACROLET) for the
|
||||
scope of the body. IT can be set with SETF."
|
||||
`(symbolic when ,test ,@body))
|
||||
|
||||
(defmacro sunless (test &body body)
|
||||
"Like UNLESS, except binds the test form to IT (via SYMBOL-MACROLET) for the
|
||||
scope of the body. IT can be set with SETF."
|
||||
`(symbolic unless ,test ,@body))
|
||||
|
||||
(defmacro acase (keyform &body cases)
|
||||
"Like CASE, except binds the result of the keyform to IT (via LET) for the
|
||||
scope of the cases."
|
||||
`(anaphoric case ,keyform ,@cases))
|
||||
|
||||
(defmacro scase (keyform &body cases)
|
||||
"Like CASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
|
||||
scope of the body. IT can be set with SETF."
|
||||
`(symbolic case ,keyform ,@cases))
|
||||
|
||||
(defmacro aecase (keyform &body cases)
|
||||
"Like ECASE, except binds the result of the keyform to IT (via LET) for the
|
||||
scope of the cases."
|
||||
`(anaphoric ecase ,keyform ,@cases))
|
||||
|
||||
(defmacro secase (keyform &body cases)
|
||||
"Like ECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
|
||||
scope of the cases. IT can be set with SETF."
|
||||
`(symbolic ecase ,keyform ,@cases))
|
||||
|
||||
(defmacro accase (keyform &body cases)
|
||||
"Like CCASE, except binds the result of the keyform to IT (via LET) for the
|
||||
scope of the cases. Unlike CCASE, the keyform/place doesn't receive new values
|
||||
possibly stored with STORE-VALUE restart; the new value is received by IT."
|
||||
`(anaphoric ccase ,keyform ,@cases))
|
||||
|
||||
(defmacro sccase (keyform &body cases)
|
||||
"Like CCASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
|
||||
scope of the cases. IT can be set with SETF."
|
||||
`(symbolic ccase ,keyform ,@cases))
|
||||
|
||||
(defmacro atypecase (keyform &body cases)
|
||||
"Like TYPECASE, except binds the result of the keyform to IT (via LET) for
|
||||
the scope of the cases."
|
||||
`(anaphoric typecase ,keyform ,@cases))
|
||||
|
||||
(defmacro stypecase (keyform &body cases)
|
||||
"Like TYPECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for the
|
||||
scope of the cases. IT can be set with SETF."
|
||||
`(symbolic typecase ,keyform ,@cases))
|
||||
|
||||
(defmacro aetypecase (keyform &body cases)
|
||||
"Like ETYPECASE, except binds the result of the keyform to IT (via LET) for
|
||||
the scope of the cases."
|
||||
`(anaphoric etypecase ,keyform ,@cases))
|
||||
|
||||
(defmacro setypecase (keyform &body cases)
|
||||
"Like ETYPECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for
|
||||
the scope of the cases. IT can be set with SETF."
|
||||
`(symbolic etypecase ,keyform ,@cases))
|
||||
|
||||
(defmacro actypecase (keyform &body cases)
|
||||
"Like CTYPECASE, except binds the result of the keyform to IT (via LET) for
|
||||
the scope of the cases. Unlike CTYPECASE, new values possible stored by the
|
||||
STORE-VALUE restart are not received by the keyform/place, but by IT."
|
||||
`(anaphoric ctypecase ,keyform ,@cases))
|
||||
|
||||
(defmacro sctypecase (keyform &body cases)
|
||||
"Like CTYPECASE, except binds the keyform to IT (via SYMBOL-MACROLET) for
|
||||
the scope of the cases. IT can be set with SETF."
|
||||
`(symbolic ctypecase ,keyform ,@cases))
|
||||
|
||||
(defmacro acond (&body clauses)
|
||||
"Like COND, except result of each test-form is bound to IT (via LET) for the
|
||||
scope of the corresponding clause."
|
||||
(labels ((rec (clauses)
|
||||
(if clauses
|
||||
(destructuring-bind ((test &body body) . rest) clauses
|
||||
(if body
|
||||
`(anaphoric if ,test (progn ,@body) ,(rec rest))
|
||||
`(anaphoric if ,test it ,(rec rest))))
|
||||
nil)))
|
||||
(rec clauses)))
|
||||
|
||||
(defmacro scond (&body clauses)
|
||||
"Like COND, except each test-form is bound to IT (via SYMBOL-MACROLET) for the
|
||||
scope of the corresponsing clause. IT can be set with SETF."
|
||||
(labels ((rec (clauses)
|
||||
(if clauses
|
||||
(destructuring-bind ((test &body body) . rest) clauses
|
||||
(if body
|
||||
`(symbolic if ,test (progn ,@body) ,(rec rest))
|
||||
`(symbolic if ,test it ,(rec rest))))
|
||||
nil)))
|
||||
(rec clauses)))
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: ANAPHORA -*-
|
||||
|
||||
;;;; Anaphora: The Anaphoric Macro Package from Hell
|
||||
;;;;
|
||||
;;;; This been placed in Public Domain by the author,
|
||||
;;;; Nikodemus Siivola <nikodemus@random-state.net>
|
||||
|
||||
(in-package :anaphora)
|
||||
|
||||
(defmacro with-unique-names ((&rest bindings) &body body)
|
||||
`(let ,(mapcar #'(lambda (binding)
|
||||
(destructuring-bind (var prefix)
|
||||
(if (consp binding) binding (list binding binding))
|
||||
`(,var (gensym ,(string prefix)))))
|
||||
bindings)
|
||||
,@body))
|
||||
|
||||
(defmacro ignore-first (first expr)
|
||||
(declare (ignore first))
|
||||
expr)
|
||||
|
|
@ -0,0 +1,90 @@
|
|||
;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: CL-USER -*-
|
||||
|
||||
;;;; Anaphora: The Anaphoric Macro Package from Hell
|
||||
;;;;
|
||||
;;;; This been placed in Public Domain by the author,
|
||||
;;;; Nikodemus Siivola <nikodemus@random-state.net>
|
||||
|
||||
(defpackage :anaphora
|
||||
(:use :cl)
|
||||
(:export
|
||||
#:it
|
||||
#:alet
|
||||
#:slet
|
||||
#:aif
|
||||
#:aand
|
||||
#:sor
|
||||
#:awhen
|
||||
#:aprog1
|
||||
#:acase
|
||||
#:aecase
|
||||
#:accase
|
||||
#:atypecase
|
||||
#:aetypecase
|
||||
#:actypecase
|
||||
#:acond
|
||||
#:sif
|
||||
#:asif
|
||||
#:swhen
|
||||
#:sunless
|
||||
#:scase
|
||||
#:secase
|
||||
#:sccase
|
||||
#:stypecase
|
||||
#:setypecase
|
||||
#:sctypecase
|
||||
#:scond)
|
||||
(:documentation
|
||||
"ANAPHORA provides a full complement of anaphoric macros. Subsets of the
|
||||
functionality provided by this package are exported from ANAPHORA-BASIC and
|
||||
ANAPHORA-SYMBOL."))
|
||||
|
||||
(defpackage :anaphora-basic
|
||||
(:use :cl :anaphora)
|
||||
(:export
|
||||
#:it
|
||||
#:alet
|
||||
#:aif
|
||||
#:aand
|
||||
#:awhen
|
||||
#:aprog1
|
||||
#:acase
|
||||
#:aecase
|
||||
#:accase
|
||||
#:atypecase
|
||||
#:aetypecase
|
||||
#:actypecase
|
||||
#:acond)
|
||||
(:documentation
|
||||
"ANAPHORA-BASIC provides all normal anaphoric constructs, which bind
|
||||
primary values to IT."))
|
||||
|
||||
(defpackage :anaphora-symbol
|
||||
(:use :cl :anaphora)
|
||||
(:export
|
||||
#:it
|
||||
#:slet
|
||||
#:sor
|
||||
#:sif
|
||||
#:asif
|
||||
#:swhen
|
||||
#:sunless
|
||||
#:scase
|
||||
#:secase
|
||||
#:sccase
|
||||
#:stypecase
|
||||
#:setypecase
|
||||
#:sctypecase
|
||||
#:scond)
|
||||
(:documentation
|
||||
"ANAPHORA-SYMBOL provides ``symbolic anaphoric macros'', which bind forms
|
||||
to IT via SYMBOL-MACROLET.
|
||||
|
||||
Examples:
|
||||
|
||||
(sor (gethash key table) (setf it default))
|
||||
|
||||
(asif (gethash key table)
|
||||
(foo it) ; IT is a value bound by LET here
|
||||
(setf it default)) ; IT is the GETHASH form bound by SYMBOL-MACROLET here
|
||||
"))
|
||||
|
|
@ -0,0 +1,54 @@
|
|||
;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: ANAPHORA -*-
|
||||
|
||||
;;;; Copyright (c) 2003 Brian Mastenbrook
|
||||
|
||||
;;;; Permission is hereby granted, free of charge, to any person obtaining
|
||||
;;;; a copy of this software and associated documentation files (the
|
||||
;;;; "Software"), to deal in the Software without restriction, including
|
||||
;;;; without limitation the rights to use, copy, modify, merge, publish,
|
||||
;;;; distribute, sublicense, and/or sell copies of the Software, and to
|
||||
;;;; permit persons to whom the Software is furnished to do so, subject to
|
||||
;;;; the following conditions:
|
||||
|
||||
;;;; The above copyright notice and this permission notice shall be
|
||||
;;;; included in all copies or substantial portions of the Software.
|
||||
|
||||
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
||||
;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
|
||||
;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
||||
;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
|
||||
;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
|
||||
;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
||||
|
||||
(in-package :anaphora)
|
||||
|
||||
(defmacro internal-symbol-macrolet (&rest whatever)
|
||||
`(symbol-macrolet ,@whatever))
|
||||
|
||||
(define-setf-expander internal-symbol-macrolet (binding-forms place &environment env)
|
||||
(multiple-value-bind (dummies vals newvals setter getter)
|
||||
(get-setf-expansion place env)
|
||||
(values dummies
|
||||
(substitute `(symbol-macrolet ,binding-forms it) 'it vals)
|
||||
newvals
|
||||
`(symbol-macrolet ,binding-forms ,setter)
|
||||
`(symbol-macrolet ,binding-forms ,getter))))
|
||||
|
||||
(with-unique-names (s-indicator current-s-indicator)
|
||||
(defmacro symbolic (operation test &rest other-args)
|
||||
(with-unique-names (this-s)
|
||||
(let ((current-s (get s-indicator current-s-indicator)))
|
||||
(setf (get s-indicator current-s-indicator) this-s)
|
||||
`(symbol-macrolet
|
||||
((,this-s (internal-symbol-macrolet ((it ,current-s)) ,test))
|
||||
(it ,this-s))
|
||||
(,operation it ,@other-args)))))
|
||||
|
||||
(defmacro anaphoric (op test &body body)
|
||||
(with-unique-names (this-s)
|
||||
(setf (get s-indicator current-s-indicator) this-s)
|
||||
`(let* ((it ,test)
|
||||
(,this-s it))
|
||||
(declare (ignorable ,this-s))
|
||||
(,op it ,@body)))))
|
||||
|
|
@ -0,0 +1,427 @@
|
|||
;;;; Anaphora: The Anaphoric Macro Package from Hell
|
||||
;;;;
|
||||
;;;; This been placed in Public Domain by the author,
|
||||
;;;; Nikodemus Siivola <nikodemus@random-state.net>
|
||||
|
||||
(defpackage :anaphora-test
|
||||
(:use :cl :anaphora :rt))
|
||||
|
||||
(in-package :anaphora-test)
|
||||
|
||||
(deftest alet.1
|
||||
(alet (1+ 1)
|
||||
(1+ it))
|
||||
3)
|
||||
|
||||
(deftest alet.2
|
||||
(alet (1+ 1)
|
||||
it
|
||||
(1+ it))
|
||||
3)
|
||||
|
||||
(deftest slet.1
|
||||
(let ((x (list 1 2 3)))
|
||||
(slet (car x)
|
||||
(incf it) (values it x)))
|
||||
2 (2 2 3))
|
||||
|
||||
(deftest aand.1
|
||||
(aand (+ 1 1)
|
||||
(+ 1 it))
|
||||
3)
|
||||
|
||||
(deftest aand.2
|
||||
(aand 1 t (values it 2))
|
||||
1 2)
|
||||
|
||||
(deftest aand.3
|
||||
(let ((x 1))
|
||||
(aand (incf x) t t (values t it)))
|
||||
t 2)
|
||||
|
||||
(deftest aand.4
|
||||
(aand 1 (values t it))
|
||||
t 1)
|
||||
|
||||
#+(or)
|
||||
;;; bug or a feature? forms like this expand to
|
||||
;;;
|
||||
;;; (let ((it (values ...))) (and it ...))
|
||||
;;;
|
||||
(deftest aand.5
|
||||
(aand (values nil t) it)
|
||||
nil t)
|
||||
|
||||
(deftest sor.1
|
||||
(let ((x (list nil)))
|
||||
(sor (car x)
|
||||
(setf it t))
|
||||
x)
|
||||
(t))
|
||||
|
||||
(deftest aif.1
|
||||
(aif (+ 1 1)
|
||||
(+ 1 it)
|
||||
:never)
|
||||
3)
|
||||
|
||||
(deftest aif.2
|
||||
(let ((x 0))
|
||||
(aif (incf x)
|
||||
it
|
||||
:never))
|
||||
1)
|
||||
|
||||
(deftest aif.3
|
||||
(let ((x 0))
|
||||
(aif (eval `(and ,(incf x) nil))
|
||||
:never
|
||||
(list it x)))
|
||||
(nil 1))
|
||||
|
||||
(deftest sif.1
|
||||
(let ((x (list nil)))
|
||||
(sif (car x)
|
||||
(setf it :oops)
|
||||
(setf it :yes!))
|
||||
(car x))
|
||||
:yes!)
|
||||
|
||||
(deftest sif.2
|
||||
(let ((x (list t)))
|
||||
(sif (car x)
|
||||
(setf it :yes!)
|
||||
(setf it :oops))
|
||||
(car x))
|
||||
:yes!)
|
||||
|
||||
(deftest sif.3
|
||||
(sif (list 1 2 3)
|
||||
(sif (car it)
|
||||
(setf it 'a)
|
||||
:foo))
|
||||
a)
|
||||
|
||||
(deftest sif.4
|
||||
(progn
|
||||
(defclass sif.4 ()
|
||||
((a :initform (list :sif))))
|
||||
(with-slots (a)
|
||||
(make-instance 'sif.4)
|
||||
(sif a
|
||||
(sif (car it)
|
||||
it))))
|
||||
:sif)
|
||||
|
||||
(deftest asif.1
|
||||
(let ((x (list 0)))
|
||||
(asif (incf (car x))
|
||||
it
|
||||
(list :oops it)))
|
||||
1)
|
||||
|
||||
(deftest asif.2
|
||||
(let ((x (list nil)))
|
||||
(asif (car x)
|
||||
(setf x :oops)
|
||||
(setf it :yes!))
|
||||
x)
|
||||
(:yes!))
|
||||
|
||||
(deftest awhen.1
|
||||
(let ((x 0))
|
||||
(awhen (incf x)
|
||||
(+ 1 it)))
|
||||
2)
|
||||
|
||||
(deftest awhen.2
|
||||
(let ((x 0))
|
||||
(or (awhen (not (incf x))
|
||||
t)
|
||||
x))
|
||||
1)
|
||||
|
||||
(deftest swhen.1
|
||||
(let ((x 0))
|
||||
(swhen x
|
||||
(setf it :ok))
|
||||
x)
|
||||
:ok)
|
||||
|
||||
(deftest swhen.2
|
||||
(let ((x nil))
|
||||
(swhen x
|
||||
(setf it :oops))
|
||||
x)
|
||||
nil)
|
||||
|
||||
(deftest sunless.1
|
||||
(let ((x nil))
|
||||
(sunless x
|
||||
(setf it :ok))
|
||||
x)
|
||||
:ok)
|
||||
|
||||
(deftest sunless.2
|
||||
(let ((x t))
|
||||
(sunless x
|
||||
(setf it :oops))
|
||||
x)
|
||||
t)
|
||||
|
||||
(deftest acase.1
|
||||
(let ((x 0))
|
||||
(acase (incf x)
|
||||
(0 :no)
|
||||
(1 (list :yes it))
|
||||
(2 :nono)))
|
||||
(:yes 1))
|
||||
|
||||
(deftest scase.1
|
||||
(let ((x (list 3)))
|
||||
(scase (car x)
|
||||
(0 (setf it :no))
|
||||
(3 (setf it :yes!))
|
||||
(t (setf it :nono)))
|
||||
x)
|
||||
(:yes!))
|
||||
|
||||
(deftest aecase.1
|
||||
(let ((x (list :x)))
|
||||
(aecase (car x)
|
||||
(:y :no)
|
||||
(:x (list it :yes))))
|
||||
(:x :yes))
|
||||
|
||||
(deftest aecase.2
|
||||
(nth-value 0 (ignore-errors
|
||||
(let ((x (list :x)))
|
||||
(secase (car x)
|
||||
(:y :no)))
|
||||
:oops))
|
||||
nil)
|
||||
|
||||
(deftest secase.1
|
||||
(let ((x (list :x)))
|
||||
(secase (car x)
|
||||
(:y (setf it :no))
|
||||
(:x (setf it :yes)))
|
||||
x)
|
||||
(:yes))
|
||||
|
||||
(deftest secase.2
|
||||
(nth-value 0 (ignore-errors
|
||||
(let ((x (list :x)))
|
||||
(secase (car x)
|
||||
(:y (setf it :no)))
|
||||
:oops)))
|
||||
nil)
|
||||
|
||||
(deftest accase.1
|
||||
(let ((x (list :x)))
|
||||
(accase (car x)
|
||||
(:y :no)
|
||||
(:x (list it :yes))))
|
||||
(:x :yes))
|
||||
|
||||
(deftest accase.2
|
||||
(let ((x (list :x)))
|
||||
(handler-bind ((type-error (lambda (e) (store-value :z e))))
|
||||
(accase (car x)
|
||||
(:y (setf x :no))
|
||||
(:z (setf x :yes))))
|
||||
x)
|
||||
:yes)
|
||||
|
||||
(deftest accase.3
|
||||
(let ((x (list :x)))
|
||||
(accase (car x)
|
||||
(:x (setf it :foo)))
|
||||
x)
|
||||
(:x))
|
||||
|
||||
(deftest sccase.1
|
||||
(let ((x (list :x)))
|
||||
(sccase (car x)
|
||||
(:y (setf it :no))
|
||||
(:x (setf it :yes)))
|
||||
x)
|
||||
(:yes))
|
||||
|
||||
(deftest sccase.2
|
||||
(let ((x (list :x)))
|
||||
(handler-bind ((type-error (lambda (e) (store-value :z e))))
|
||||
(sccase (car x)
|
||||
(:y (setf it :no))
|
||||
(:z (setf it :yes))))
|
||||
x)
|
||||
(:yes))
|
||||
|
||||
(deftest atypecase.1
|
||||
(atypecase 1.0
|
||||
(integer (+ 2 it))
|
||||
(float (1- it)))
|
||||
0.0)
|
||||
|
||||
(deftest atypecase.2
|
||||
(atypecase "Foo"
|
||||
(fixnum :no)
|
||||
(hash-table :nono))
|
||||
nil)
|
||||
|
||||
(deftest stypecase.1
|
||||
(let ((x (list 'foo)))
|
||||
(stypecase (car x)
|
||||
(vector (setf it :no))
|
||||
(symbol (setf it :yes)))
|
||||
x)
|
||||
(:yes))
|
||||
|
||||
(deftest stypecase.2
|
||||
(let ((x (list :bar)))
|
||||
(stypecase (car x)
|
||||
(fixnum (setf it :no)))
|
||||
x)
|
||||
(:bar))
|
||||
|
||||
(deftest aetypecase.1
|
||||
(aetypecase 1.0
|
||||
(fixnum (* 2 it))
|
||||
(float (+ 2.0 it))
|
||||
(symbol :oops))
|
||||
3.0)
|
||||
|
||||
(deftest aetypecase.2
|
||||
(nth-value 0 (ignore-errors
|
||||
(aetypecase 1.0
|
||||
(symbol :oops))))
|
||||
nil)
|
||||
|
||||
(deftest setypecase.1
|
||||
(let ((x (list "Foo")))
|
||||
(setypecase (car x)
|
||||
(symbol (setf it :no))
|
||||
(string (setf it "OK"))
|
||||
(integer (setf it :noon)))
|
||||
x)
|
||||
("OK"))
|
||||
|
||||
(deftest setypecase.2
|
||||
(nth-value 0 (ignore-errors
|
||||
(setypecase 'foo
|
||||
(string :nono))))
|
||||
nil)
|
||||
|
||||
(deftest actypecase.1
|
||||
(actypecase :foo
|
||||
(string (list :string it))
|
||||
(keyword (list :keyword it))
|
||||
(symbol (list :symbol it)))
|
||||
(:keyword :foo))
|
||||
|
||||
(deftest actypecase.2
|
||||
(handler-bind ((type-error (lambda (e) (store-value "OK" e))))
|
||||
(actypecase 0
|
||||
(string it)))
|
||||
"OK")
|
||||
|
||||
(deftest sctypecase.1
|
||||
(let ((x (list 0)))
|
||||
(sctypecase (car x)
|
||||
(symbol (setf it 'symbol))
|
||||
(bit (setf it 'bit)))
|
||||
x)
|
||||
(bit))
|
||||
|
||||
(deftest sctypecase.2
|
||||
(handler-bind ((type-error (lambda (e) (store-value "OK" e))))
|
||||
(let ((x (list 0)))
|
||||
(sctypecase (car x)
|
||||
(string (setf it :ok)))
|
||||
x))
|
||||
(:ok))
|
||||
|
||||
(deftest acond.1
|
||||
(acond (:foo))
|
||||
:foo)
|
||||
|
||||
(deftest acond.2
|
||||
(acond ((null 1) (list :no it))
|
||||
((+ 1 2) (list :yes it))
|
||||
(t :nono))
|
||||
(:yes 3))
|
||||
|
||||
(deftest acond.3
|
||||
(acond ((= 1 2) :no)
|
||||
(nil :nono)
|
||||
(t :yes))
|
||||
:yes)
|
||||
|
||||
;; Test COND with multiple forms in the implicit progn.
|
||||
(deftest acond.4
|
||||
(let ((foo))
|
||||
(acond ((+ 2 2) (setf foo 38) (incf foo it) foo)
|
||||
(t nil)))
|
||||
42)
|
||||
|
||||
(deftest scond.1
|
||||
(let ((x (list nil))
|
||||
(y (list t)))
|
||||
(scond ((car x) (setf it :nono))
|
||||
((car y) (setf it :yes)))
|
||||
(values x y))
|
||||
(nil)
|
||||
(:yes))
|
||||
|
||||
(deftest scond.2
|
||||
(scond ((= 1 2) :no!))
|
||||
nil)
|
||||
|
||||
(deftest aprog.1
|
||||
(aprog1 :yes
|
||||
(unless (eql it :yes) (error "Broken."))
|
||||
:no)
|
||||
:yes)
|
||||
|
||||
(deftest aif.sif.1
|
||||
(sif 1 (aif it it))
|
||||
1)
|
||||
|
||||
(deftest aif.sif.2
|
||||
(aif 1 (sif it it))
|
||||
1)
|
||||
|
||||
(deftest aif.sif.3
|
||||
(aif (list 1 2 3)
|
||||
(sif (car it)
|
||||
(setf it 'a)
|
||||
:foo))
|
||||
a)
|
||||
|
||||
(deftest alet.slet.1
|
||||
(slet 42 (alet 43 (slet it it)))
|
||||
43)
|
||||
|
||||
|
||||
(defun elt-like (index seq)
|
||||
(elt seq index))
|
||||
|
||||
(define-setf-expander elt-like (index seq)
|
||||
(let ((index-var (gensym "index"))
|
||||
(seq-var (gensym "seq"))
|
||||
(store (gensym "store")))
|
||||
(values (list index-var seq-var)
|
||||
(list index seq)
|
||||
(list store)
|
||||
`(if (listp ,seq-var)
|
||||
(setf (nth ,index-var ,seq-var) ,store)
|
||||
(setf (aref ,seq-var ,index-var) ,store))
|
||||
`(if (listp ,seq-var)
|
||||
(nth ,index-var ,seq-var)
|
||||
(aref ,seq-var ,index-var)))))
|
||||
|
||||
(deftest symbolic.setf-expansion.1
|
||||
(let ((cell (list nil)))
|
||||
(sor (elt-like 0 cell) (setf it 1))
|
||||
(equal cell '(1)))
|
||||
t)
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
before_script:
|
||||
- curl -O -L http://prdownloads.sourceforge.net/sbcl/sbcl-1.2.6-x86-64-linux-binary.tar.bz2
|
||||
- tar xjf sbcl-1.2.6-x86-64-linux-binary.tar.bz2
|
||||
- pushd sbcl-1.2.6-x86-64-linux/ && sudo bash install.sh && popd
|
||||
- curl -O -L http://beta.quicklisp.org/quicklisp.lisp
|
||||
- sbcl --load quicklisp.lisp --eval '(quicklisp-quickstart:install)' --eval '(quit)'
|
||||
- curl -OL http://ccl.clozure.com/ftp/pub/release/1.10/ccl-1.10-linuxx86.tar.gz
|
||||
- tar xzf ccl-1.10-linuxx86.tar.gz
|
||||
- export PATH=`pwd`/ccl:$PATH
|
||||
# - lx86cl64 -b --load quicklisp.lisp --eval '(progn (quicklisp-quickstart:install) (quit))'
|
||||
|
||||
script:
|
||||
- ./ci-test-run.sh
|
||||
|
|
@ -0,0 +1,140 @@
|
|||
# cl-ansi-text
|
||||
|
||||
Because color in your terminal is nice.
|
||||
[](https://travis-ci.org/pnathan/cl-ansi-text)
|
||||
|
||||
## Usage example -
|
||||
```lisp
|
||||
* (ql:quickload :cl-ansi-text)
|
||||
;To load "cl-ansi-text":
|
||||
; Load 1 ASDF system:
|
||||
; cl-ansi-text
|
||||
;; Loading "cl-ansi-text"
|
||||
; => (:CL-ANSI-TEXT)
|
||||
```
|
||||
|
||||
The main macro is called `with-color`, which creates an enviroment where everything that is put on `stream` gets colored according to `color`. Color options are `:black`, `:red`, `:green`, `:yellow`, `:blue`, `:magenta`, `:cyan` and `:white`. You can also use a color structure from `CL-COLORS`, like `cl-colors:+red+`.
|
||||
|
||||
```lisp
|
||||
* (import 'cl-ansi-text:with-color)
|
||||
; => T
|
||||
* (with-color (:red)
|
||||
(princ "Gets printed red...")
|
||||
(princ "and this too!"))
|
||||
; Gets printed red...and this too!
|
||||
; => "and this too!"
|
||||
```
|
||||
|
||||
There are also functions with the name of the colors, that return the string, colored:
|
||||
```lisp
|
||||
* (import 'cl-ansi-text:yellow)
|
||||
; => T
|
||||
* (yellow "Yellow string")
|
||||
; => "Yellow string"
|
||||
* (princ (yellow "String with yellow background" :style :background))
|
||||
; "String with yellow background"
|
||||
; => "String with yellow background"
|
||||
* (import 'cl-ansi-text:red)
|
||||
; => T
|
||||
* (princ
|
||||
(concatenate
|
||||
'string
|
||||
(yellow "Five") " test results went " (red "terribly wrong") "!"))
|
||||
; Five test results went terribly wrong!
|
||||
; => "Five test results went terribly wrong!"
|
||||
```
|
||||
At any point, you can bind the `*enabled*` special variable to `nil`, and anything inside that binding will not be printed colorfully:
|
||||
```lisp
|
||||
* (let (cl-ansi-text:*enabled*)
|
||||
(princ (red "This string is printed normally")))
|
||||
```
|
||||
|
||||
# API
|
||||
|
||||
|
||||
## BLUE
|
||||
|
||||
Returns a string with the `blue'string denotation preppended and the `reset' string denotation appended.
|
||||
|
||||
*enabled* dynamically controls the function.
|
||||
|
||||
## MAGENTA
|
||||
|
||||
Returns a string with the `magenta'string denotation preppended and the `reset' string denotation appended.
|
||||
|
||||
*enabled* dynamically controls the function.
|
||||
|
||||
## CYAN
|
||||
|
||||
Returns a string with the `cyan'string denotation preppended and the `reset' string denotation appended.
|
||||
|
||||
*enabled* dynamically controls the function.
|
||||
|
||||
## GREEN
|
||||
|
||||
Returns a string with the `green'string denotation preppended and the `reset' string denotation appended.
|
||||
|
||||
*enabled* dynamically controls the function.
|
||||
|
||||
## WITH-COLOR
|
||||
|
||||
Writes out the string denoting a switch to `color`, executes body,
|
||||
then writes out the string denoting a `reset`.
|
||||
|
||||
*enabled* dynamically controls expansion..
|
||||
|
||||
## YELLOW
|
||||
|
||||
Returns a string with the `yellow'string denotation preppended and the `reset' string denotation appended.
|
||||
|
||||
*enabled* dynamically controls the function.
|
||||
|
||||
## BLACK
|
||||
|
||||
Returns a string with the `black'string denotation preppended and the `reset' string denotation appended.
|
||||
|
||||
*enabled* dynamically controls the function.
|
||||
|
||||
## *ENABLED*
|
||||
|
||||
Turns on/off the colorization of functions
|
||||
|
||||
## MAKE-COLOR-STRING
|
||||
|
||||
Takes either a cl-color or a list denoting the ANSI colors and
|
||||
returns a string sufficient to change to the given color.
|
||||
|
||||
Will be dynamically controlled by *enabled* unless manually specified
|
||||
otherwise
|
||||
|
||||
## RED
|
||||
|
||||
Returns a string with the `red'string denotation preppended and the `reset' string denotation appended.
|
||||
|
||||
*enabled* dynamically controls the function.
|
||||
|
||||
## WHITE
|
||||
|
||||
Returns a string with the `white'string denotation preppended and the `reset' string denotation appended.
|
||||
|
||||
*enabled* dynamically controls the function.
|
||||
|
||||
## +RESET-COLOR-STRING+
|
||||
|
||||
This string will reset ANSI colors
|
||||
|
||||
|
||||
# Note
|
||||
|
||||
Note that your terminal MUST be ANSI-compliant to show these
|
||||
colors. My SLIME REPL (as of Feb 2013) does not display these
|
||||
colors. I have to use a typical Linux/OSX terminal to see them.
|
||||
|
||||
This has been tested to work on a Linux system with SBCL, CLISP and
|
||||
CCL. CCL may not work quite perfectly, some level of conniptions were
|
||||
encountered in testing. The interested reader is advised to check the
|
||||
MAKE-LOAD-FORM defmethod in cl-ansi-text.lisp.
|
||||
|
||||
An earlier variant was tested on OSX 10.6 with SBCL.
|
||||
|
||||
License: LLGPL
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
#!/bin/bash
|
||||
error=0
|
||||
if which sbcl; then
|
||||
echo "CI run using SBCL"
|
||||
sbcl --script run-tests.lisp
|
||||
error=$?
|
||||
fi
|
||||
|
||||
if which lx86cl64; then
|
||||
echo "CI run using CCL"
|
||||
lx86cl64 -b --load run-tests.lisp
|
||||
error=$(($error+$?))
|
||||
fi
|
||||
|
||||
exit $error
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
(asdf:defsystem #:cl-ansi-text-test
|
||||
:depends-on ( #:cl-colors #:alexandria #:cl-ansi-text #:fiveam)
|
||||
:components ((:module "test"
|
||||
:components
|
||||
((:file "cl-ansi-text-test"))))
|
||||
:name "cl-ansi-text-test"
|
||||
:version "1.0"
|
||||
:maintainer "Paul Nathan"
|
||||
:author "Paul Nathan"
|
||||
:licence "LLGPL"
|
||||
:description "Test system for cl-ansi-text")
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
(asdf:defsystem #:cl-ansi-text
|
||||
:depends-on ( #:cl-colors #:alexandria)
|
||||
:components ((:file "cl-ansi-text"))
|
||||
:name "cl-ansi-text"
|
||||
:version "1.0"
|
||||
:maintainer "Paul Nathan"
|
||||
:author "Paul Nathan"
|
||||
:licence "LLGPL"
|
||||
:description "ANSI control string characters, focused on color"
|
||||
:long-description "ANSI control string management, specializing in
|
||||
colors. Sometimes it is nice to have text output in colors")
|
||||
|
|
@ -0,0 +1,285 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;; Paul Nathan 2013
|
||||
;;;; cl-ansi-text.lisp
|
||||
;;;;
|
||||
;;;; Portions of this code were written by taksatou under the
|
||||
;;;; cl-rainbow name.
|
||||
;;;;
|
||||
;;;; A library to produce ANSI escape sequences. Particularly,
|
||||
;;;; produces colorized text on terminals
|
||||
|
||||
(defpackage :cl-ansi-text
|
||||
(:use :common-lisp)
|
||||
(:export
|
||||
#:with-color
|
||||
#:make-color-string
|
||||
#:+reset-color-string+
|
||||
#:*enabled*
|
||||
#:black
|
||||
#:red
|
||||
#:green
|
||||
#:yellow
|
||||
#:blue
|
||||
#:magenta
|
||||
#:cyan
|
||||
#:white))
|
||||
(in-package :cl-ansi-text)
|
||||
|
||||
;;; !!! NOTE TO CCL USERS !!!
|
||||
;;;
|
||||
;;; This seems to be *required* to make this compile in CCL. The
|
||||
;;; reason is that CCL expects to be able to inline on compile, but
|
||||
;;; structs don't set up that infrastructure by default.
|
||||
;;;
|
||||
;;; At least from the thread "Compiler problem, MCL 3.9" by Arthur
|
||||
;;; Cater around '96.
|
||||
#+ccl(common-lisp:eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defmethod make-load-form ((obj cl-colors:rgb ) &optional env)
|
||||
(make-load-form-saving-slots obj)))
|
||||
|
||||
(defparameter *enabled* t
|
||||
"Turns on/off the colorization of functions")
|
||||
|
||||
(defparameter +reset-color-string+
|
||||
(concatenate 'string (list (code-char 27) #\[ #\0 #\m))
|
||||
"This string will reset ANSI colors")
|
||||
|
||||
(defvar +cl-colors+
|
||||
(vector
|
||||
cl-colors:+black+
|
||||
cl-colors:+red+
|
||||
cl-colors:+green+
|
||||
cl-colors:+yellow+
|
||||
cl-colors:+blue+
|
||||
cl-colors:+magenta+
|
||||
cl-colors:+cyan+
|
||||
cl-colors:+white+)
|
||||
"CL-COLORS colors")
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defparameter +term-colors+
|
||||
(vector
|
||||
:black
|
||||
:red
|
||||
:green
|
||||
:yellow
|
||||
:blue
|
||||
:magenta
|
||||
:cyan
|
||||
:white)
|
||||
"Basic colors"))
|
||||
|
||||
(defparameter +text-style+
|
||||
'((:foreground . 30)
|
||||
(:background . 40))
|
||||
"One or the other. Not an ANSI effect")
|
||||
|
||||
(defparameter +term-effects+
|
||||
'((:unset . t)
|
||||
(:reset . 0)
|
||||
(:bright . 1)
|
||||
(:italic . 3)
|
||||
(:underline . 4)
|
||||
(:blink . 5)
|
||||
(:inverse . 7)
|
||||
(:hide . 8)
|
||||
(:normal . 22)
|
||||
(:framed . 51)
|
||||
(:encircled . 52)
|
||||
(:overlined . 53)
|
||||
(:not-framed-or-circled . 54)
|
||||
(:not-overlined . 55))
|
||||
"ANSI terminal effects")
|
||||
|
||||
(defun eq-colors (a b)
|
||||
"Equality for cl-colors"
|
||||
|
||||
;; CL-COLORS LIB!
|
||||
|
||||
;; eql, equal doesn't quite work for compiled cl-colors on CCL
|
||||
(and
|
||||
(= (cl-colors:rgb-red a)
|
||||
(cl-colors:rgb-red b))
|
||||
(= (cl-colors:rgb-green a)
|
||||
(cl-colors:rgb-green b))
|
||||
(= (cl-colors:rgb-blue a)
|
||||
(cl-colors:rgb-blue b))))
|
||||
|
||||
(defun cl-colors-to-ansi (color)
|
||||
(position color +cl-colors+ :test #'eq-colors))
|
||||
|
||||
(defun term-colors-to-ansi (color)
|
||||
(position color +term-colors+))
|
||||
|
||||
|
||||
|
||||
;; Find-X-code is the top-level interface for code-finding
|
||||
|
||||
(defun find-color-code (color)
|
||||
"Find the list denoting the color"
|
||||
(typecase color
|
||||
;; Did we get a cl-color that we know about?
|
||||
(cl-colors:rgb (cl-colors-to-ansi color))
|
||||
(symbol (term-colors-to-ansi color))))
|
||||
|
||||
(defun find-effect-code (effect)
|
||||
"Returns the number for the text effect OR
|
||||
t if no effect should be used OR
|
||||
nil if the effect is unknown.
|
||||
|
||||
effect should be a member of +term-effects+"
|
||||
(cdr (assoc effect +term-effects+)))
|
||||
|
||||
(defun find-style-code (style)
|
||||
(cdr (assoc style +text-style+)))
|
||||
|
||||
(defun rgb-code-p (color)
|
||||
(typecase color
|
||||
(list t)
|
||||
(integer t)))
|
||||
|
||||
(defun generate-control-string (code)
|
||||
"General ANSI code"
|
||||
(format nil "~c[~a" (code-char #o33) code))
|
||||
|
||||
(defun generate-color-string (code)
|
||||
;; m is the action character for color
|
||||
(format nil "~am" (generate-control-string code)))
|
||||
|
||||
(defun build-control-string (color
|
||||
&optional
|
||||
(effect :unset)
|
||||
(style :foreground))
|
||||
"Color (cl-color or term-color)
|
||||
Effect
|
||||
Style"
|
||||
(let ((effect-code (find-effect-code effect))
|
||||
(color-code (find-color-code color))
|
||||
(style-code (find-style-code style)))
|
||||
|
||||
;; Nil here indicates an error
|
||||
(assert effect-code)
|
||||
(assert style-code)
|
||||
|
||||
;; Returns a list for inspection; next layer turns it back into a
|
||||
;; string.
|
||||
(concatenate
|
||||
'list
|
||||
;; We split between RGB and 32-color here; this preserves the
|
||||
;; interface without cluttering the 32-color code up.
|
||||
;;
|
||||
(let ((codes nil))
|
||||
(unless (eq effect-code t)
|
||||
(setf codes (cons effect-code codes)))
|
||||
(if (rgb-code-p color)
|
||||
(setf codes (cons (rgb-color-code color style) codes))
|
||||
(setf codes (cons (+ style-code color-code) codes)))
|
||||
|
||||
(generate-color-string (format nil "~{~A~^;~}" codes))))))
|
||||
|
||||
;; Public callables.
|
||||
|
||||
(defun make-color-string (color &key
|
||||
(effect :unset)
|
||||
(style :foreground)
|
||||
((enabled *enabled*) *enabled*))
|
||||
"Takes either a cl-color or a list denoting the ANSI colors and
|
||||
returns a string sufficient to change to the given color.
|
||||
|
||||
Will be dynamically controlled by *enabled* unless manually specified
|
||||
otherwise"
|
||||
(when *enabled*
|
||||
(concatenate 'string
|
||||
(build-control-string color effect style))))
|
||||
|
||||
(defmacro with-color ((color &key
|
||||
(stream t)
|
||||
(effect :unset)
|
||||
(style :foreground))
|
||||
&body body)
|
||||
"Writes out the string denoting a switch to `color`, executes body,
|
||||
then writes out the string denoting a `reset`.
|
||||
|
||||
*enabled* dynamically controls expansion.."
|
||||
`(progn
|
||||
(when *enabled*
|
||||
(format ,stream "~a" (make-color-string ,color
|
||||
:effect ,effect
|
||||
:style ,style)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
,@body)
|
||||
(when *enabled*
|
||||
(format ,stream "~a" +reset-color-string+)))))
|
||||
|
||||
(defmacro gen-color-functions (color-names-vector)
|
||||
`(progn
|
||||
,@(map 'list
|
||||
(lambda (color)
|
||||
`(defun ,(intern (symbol-name color)) (string &key
|
||||
(effect :unset)
|
||||
(style :foreground))
|
||||
,(concatenate
|
||||
'string
|
||||
"Returns a string with the `" (string-downcase color)
|
||||
"'string denotation preppended and the `reset' string denotation appended.
|
||||
|
||||
*enabled* dynamically controls the function." )
|
||||
(concatenate
|
||||
'string
|
||||
(when *enabled*
|
||||
(format nil "~a" (make-color-string ,color
|
||||
:effect effect
|
||||
:style style)))
|
||||
string
|
||||
(when *enabled*
|
||||
(format nil "~a" +reset-color-string+)))))
|
||||
color-names-vector)))
|
||||
|
||||
(gen-color-functions #.(coerce +term-colors+ 'list))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; RGB color codes for some enhanced terminals
|
||||
|
||||
;;; http://www.frexx.de/xterm-256-notes/
|
||||
(defun rgb-to-ansi (red green blue)
|
||||
(let ((ansi-domain (mapcar #'(lambda (x)
|
||||
(floor (* 6 (/ x 256.0))))
|
||||
(list red green blue))))
|
||||
(+ 16
|
||||
(* 36 (first ansi-domain))
|
||||
(* 6 (second ansi-domain))
|
||||
(third ansi-domain))))
|
||||
|
||||
(defun code-from-rgb (style red green blue)
|
||||
(format nil "~d;5;~d"
|
||||
(if (eql style :foreground) 38 48)
|
||||
(rgb-to-ansi red green blue)))
|
||||
|
||||
|
||||
(defgeneric rgb-color-code (color &optional style)
|
||||
(:documentation
|
||||
"Returns the 256-color code suitable for rendering on the Linux
|
||||
extensions to xterm"))
|
||||
|
||||
(defmethod rgb-color-code ((color list) &optional (style :foreground))
|
||||
(unless (consp color)
|
||||
(error "~a must be a three-integer list" color))
|
||||
|
||||
(unless (and (integerp (first color))
|
||||
(integerp (second color))
|
||||
(integerp (second color)))
|
||||
(error "~a must have three integers" color))
|
||||
|
||||
(code-from-rgb style
|
||||
(first color)
|
||||
(second color)
|
||||
(third color)))
|
||||
|
||||
(defmethod rgb-color-code ((color integer) &optional (style :foreground))
|
||||
;; Takes RGB integer ala Web integers
|
||||
(code-from-rgb style
|
||||
;; classic bitmask
|
||||
(ash (logand color #xff0000) -16)
|
||||
(ash (logand color #x00ff00) -8)
|
||||
(logand color #x0000ff)))
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
#-quicklisp
|
||||
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
|
||||
(user-homedir-pathname))))
|
||||
(when (probe-file quicklisp-init)
|
||||
(load quicklisp-init)))
|
||||
|
||||
#+sbcl(require "sb-posix")
|
||||
|
||||
(defparameter *pwd*
|
||||
(concatenate 'string
|
||||
(progn #+sbcl(sb-posix:getcwd)
|
||||
#+ccl(ccl::current-directory-name))
|
||||
"/"))
|
||||
|
||||
(push *pwd* asdf:*central-registry*)
|
||||
|
||||
|
||||
(ql:quickload '(:cl-colors
|
||||
:alexandria
|
||||
:fiveam
|
||||
|
||||
:cl-ansi-text
|
||||
:cl-ansi-text-test))
|
||||
|
||||
(let ((result-status (cl-ansi-text-test::ci-run)))
|
||||
(let ((posix-status
|
||||
(if result-status 0 1)))
|
||||
#+sbcl(sb-posix:exit posix-status)
|
||||
#+ccl (quit posix-status)))
|
||||
|
|
@ -0,0 +1,123 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; test suite for cl-ansi-text
|
||||
|
||||
(defpackage :cl-ansi-text-test
|
||||
(:use :common-lisp
|
||||
:cl-user
|
||||
:cl-ansi-text
|
||||
:fiveam))
|
||||
|
||||
(in-package :cl-ansi-text-test)
|
||||
(use-package :fiveam)
|
||||
(use-package :cl-ansi-text)
|
||||
|
||||
(def-suite test-suite
|
||||
:description "test suite.")
|
||||
|
||||
(in-suite test-suite)
|
||||
|
||||
|
||||
(test basic-color-strings
|
||||
"Test the basic stuff"
|
||||
(is (equal '(#\Esc #\[ #\3 #\1 #\m)
|
||||
(cl-ansi-text::build-control-string :red :unset :foreground)))
|
||||
(is (equal '(#\Esc #\[ #\4 #\1 #\m)
|
||||
(cl-ansi-text::build-control-string :red :unset :background)))
|
||||
(is (equal '(#\Esc #\[ #\4 #\2 #\; #\1 #\m)
|
||||
(cl-ansi-text::build-control-string :green :bright :background))))
|
||||
|
||||
(test enabled-connectivity
|
||||
"Test *enabled*'s capability"
|
||||
(is (equal '(#\Esc #\[ #\3 #\1 #\m)
|
||||
(let ((*enabled* t))
|
||||
(concatenate
|
||||
'list
|
||||
(cl-ansi-text:make-color-string :red)))))
|
||||
(is (equal '()
|
||||
(let ((*enabled* nil))
|
||||
(concatenate
|
||||
'list
|
||||
(cl-ansi-text:make-color-string :red)))))
|
||||
(is (equal "hi"
|
||||
(let ((*enabled* nil))
|
||||
(with-output-to-string (s)
|
||||
(with-color (:red :stream s) (format s "hi"))))))
|
||||
(is (equal '(#\Esc #\[ #\3 #\1 #\m #\T #\e #\s #\t #\! #\Esc #\[ #\0 #\m)
|
||||
(concatenate
|
||||
'list
|
||||
(with-output-to-string (s)
|
||||
(with-color (:red :stream s)
|
||||
(format s "Test!")))))))
|
||||
|
||||
(test rgb-suite
|
||||
"Test RGB colors"
|
||||
(is (equal '(#\Esc #\[ #\3 #\8 #\; #\5 #\; #\2 #\1 #\4 #\m)
|
||||
(cl-ansi-text::build-control-string #xFFAA00
|
||||
:unset :foreground)))
|
||||
(is (equal '(#\Esc #\[ #\4 #\8 #\; #\5 #\; #\2 #\1 #\4 #\m)
|
||||
(cl-ansi-text::build-control-string #xFFAA00
|
||||
:unset :background)))
|
||||
(is (equal '(#\Esc #\[ #\4 #\8 #\; #\5 #\; #\1 #\6 #\m)
|
||||
(cl-ansi-text::build-control-string #x000000
|
||||
:unset :background)))
|
||||
(is (equal '(#\Esc #\[ #\4 #\8 #\; #\5 #\; #\2 #\3 #\1 #\m)
|
||||
(cl-ansi-text::build-control-string #xFFFFFF
|
||||
:unset :background))))
|
||||
|
||||
(test color-named-functions
|
||||
(let ((str "Test string."))
|
||||
(is (equal (black str)
|
||||
(with-output-to-string (s)
|
||||
(with-color (:black :stream s)
|
||||
(format s str)))))
|
||||
(is (equal (red str)
|
||||
(with-output-to-string (s)
|
||||
(with-color (:red :stream s)
|
||||
(format s str)))))
|
||||
|
||||
(is (equal (green str)
|
||||
(with-output-to-string (s)
|
||||
(with-color (:green :stream s)
|
||||
(format s str)))))
|
||||
|
||||
(is (equal (yellow str)
|
||||
(with-output-to-string (s)
|
||||
(with-color (:yellow :stream s)
|
||||
(format s str)))))
|
||||
(is (equal (blue str)
|
||||
(with-output-to-string (s)
|
||||
(with-color (:blue :stream s)
|
||||
(format s str)))))
|
||||
(is (equal (magenta str)
|
||||
(with-output-to-string (s)
|
||||
(with-color (:magenta :stream s)
|
||||
(format s str)))))
|
||||
(is (equal (cyan str)
|
||||
(with-output-to-string (s)
|
||||
(with-color (:cyan :stream s)
|
||||
(format s str)))))
|
||||
(is (equal (white str)
|
||||
(with-output-to-string (s)
|
||||
(with-color (:white :stream s)
|
||||
(format s str)))))))
|
||||
|
||||
(test color-named-functions-*enabled*
|
||||
(let ((str "Other test string.")
|
||||
(*enabled* nil))
|
||||
(is
|
||||
(equal str
|
||||
(white (cyan (magenta (blue (yellow (green (red (black str))))))))))))
|
||||
|
||||
(defun run-tests ()
|
||||
(let ((results (run 'test-suite)))
|
||||
(explain! results)
|
||||
(if (position-if #'(lambda (e)
|
||||
(eq (type-of e)
|
||||
'IT.BESE.FIVEAM::TEST-FAILURE
|
||||
))
|
||||
results)
|
||||
nil
|
||||
t)))
|
||||
|
||||
(defun ci-run ()
|
||||
(run-tests))
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
## note: this works on my system, you don't need to run it because the
|
||||
## distribution contains the generated file
|
||||
|
||||
SBCL=/usr/bin/sbcl
|
||||
|
||||
colornames.lisp: /usr/share/X11/rgb.txt parse-x11-colors.lisp
|
||||
rm -f colornames.lisp
|
||||
$(SBCL) --load parse-x11-colors.lisp --eval '(quit)'
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
*IMPORTANT* This library is [[https://tpapp.github.io/post/orphaned-lisp-libraries/][unsupported]].
|
||||
|
||||
* cl-colors: a simple color library for Common Lisp
|
||||
|
||||
This is a very simple color library for Common Lisp, providing
|
||||
|
||||
1. Types for representing colors in HSV and RGB spaces.
|
||||
2. Simple conversion functions between the above types (and also hexadecimal representation for RGB).
|
||||
3. Some predefined colors (currently X11 color names -- of course the library does not depend on X11).
|
||||
|
||||
** Examples
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
(let ((color1 (hsv 107 62/100 52/100)) ; greenish
|
||||
(color2 (rgb 14/15 26/51 14/15)) ; = violet from X11
|
||||
(color3 (as-rgb "ff9e00"))) ; from hexadecimal
|
||||
(list ;
|
||||
(as-rgb color1) ; converting to RGB
|
||||
(rgb-combination color1 +blue+ 0.4) ; HSV autoconverted to RGB
|
||||
(hsv-combination color2 +blue+ 0.4) ; RGB autoconverted to HSV
|
||||
color3))
|
||||
#+END_SRC
|
||||
evaluates to
|
||||
#+BEGIN_EXAMPLE
|
||||
'(#S(RGB :RED 20059/75000 :GREEN 13/25 :BLUE 247/1250)
|
||||
#S(RGB :RED 0.160472 :GREEN 0.312 :BLUE 0.51856) ; observe float contagion
|
||||
#S(HSV :HUE 60.0 :SATURATION 0.6722689 :VALUE 0.96000004)
|
||||
#S(RGB :RED 1 :GREEN 158/255 :BLUE 0))
|
||||
#+END_EXAMPLE
|
||||
|
||||
Observe the float contagion: =cl-colors= functions don't care about the type of the numbers as long as they are a subtype of =real= and within the right range.
|
||||
|
||||
** Documentation
|
||||
|
||||
This library is so simple that it does not need a lot of documentation --- just look at the docsstrings in =colors.lisp=.
|
||||
|
||||
** Regeneration of the X11 color names
|
||||
|
||||
Normally you should not need to do this, the sources already contain the autogenerated file =colornames.lisp=. However, if for some reason you need to regenerate this, you can use =make=. Even though the library itself does not depend on X11, regenerating this file will require the appropriate file in X11.
|
||||
|
||||
** Bugs and issues
|
||||
|
||||
Please report them on [[https://github.com/tpapp/cl-colors/issues][Github]].
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
(defsystem #:cl-colors
|
||||
:description "Simple color library for Common Lisp"
|
||||
:version "0.2"
|
||||
:author "Tamas K Papp <tkpapp@gmail.com>"
|
||||
:license "Boost Software License - Version 1.0"
|
||||
:serial t
|
||||
:components ((:file "package")
|
||||
(:file "colors")
|
||||
(:file "colornames")
|
||||
(:file "hexcolors"))
|
||||
:depends-on (#:alexandria #:let-plus))
|
||||
|
||||
(defsystem #:cl-colors-tests
|
||||
:description "Unit tests for CL-COLORS."
|
||||
:author "Tamas K Papp <tkpapp@gmail.com>"
|
||||
:license "Boost Software License - Version 1.0"
|
||||
:serial t
|
||||
:components ((:file "test"))
|
||||
:depends-on (#:cl-colors #:lift))
|
||||
|
|
@ -0,0 +1,663 @@
|
|||
;;;; This file was generated automatically by parse-x11.lisp
|
||||
;;;; Please do not edit directly, just run make if necessary (but should not be).
|
||||
|
||||
(in-package #:cl-colors)
|
||||
|
||||
(define-rgb-color snow 1 50/51 50/51)
|
||||
(define-rgb-color ghostwhite 248/255 248/255 1)
|
||||
(define-rgb-color whitesmoke 49/51 49/51 49/51)
|
||||
(define-rgb-color gainsboro 44/51 44/51 44/51)
|
||||
(define-rgb-color floralwhite 1 50/51 16/17)
|
||||
(define-rgb-color oldlace 253/255 49/51 46/51)
|
||||
(define-rgb-color linen 50/51 16/17 46/51)
|
||||
(define-rgb-color antiquewhite 50/51 47/51 43/51)
|
||||
(define-rgb-color papayawhip 1 239/255 71/85)
|
||||
(define-rgb-color blanchedalmond 1 47/51 41/51)
|
||||
(define-rgb-color bisque 1 76/85 196/255)
|
||||
(define-rgb-color peachpuff 1 218/255 37/51)
|
||||
(define-rgb-color navajowhite 1 74/85 173/255)
|
||||
(define-rgb-color moccasin 1 76/85 181/255)
|
||||
(define-rgb-color cornsilk 1 248/255 44/51)
|
||||
(define-rgb-color ivory 1 1 16/17)
|
||||
(define-rgb-color lemonchiffon 1 50/51 41/51)
|
||||
(define-rgb-color seashell 1 49/51 14/15)
|
||||
(define-rgb-color honeydew 16/17 1 16/17)
|
||||
(define-rgb-color mintcream 49/51 1 50/51)
|
||||
(define-rgb-color azure 16/17 1 1)
|
||||
(define-rgb-color aliceblue 16/17 248/255 1)
|
||||
(define-rgb-color lavender 46/51 46/51 50/51)
|
||||
(define-rgb-color lavenderblush 1 16/17 49/51)
|
||||
(define-rgb-color mistyrose 1 76/85 15/17)
|
||||
(define-rgb-color white 1 1 1)
|
||||
(define-rgb-color black 0 0 0)
|
||||
(define-rgb-color darkslategray 47/255 79/255 79/255)
|
||||
(define-rgb-color darkslategrey 47/255 79/255 79/255)
|
||||
(define-rgb-color dimgray 7/17 7/17 7/17)
|
||||
(define-rgb-color dimgrey 7/17 7/17 7/17)
|
||||
(define-rgb-color slategray 112/255 128/255 48/85)
|
||||
(define-rgb-color slategrey 112/255 128/255 48/85)
|
||||
(define-rgb-color lightslategray 7/15 8/15 3/5)
|
||||
(define-rgb-color lightslategrey 7/15 8/15 3/5)
|
||||
(define-rgb-color gray 38/51 38/51 38/51)
|
||||
(define-rgb-color grey 38/51 38/51 38/51)
|
||||
(define-rgb-color lightgrey 211/255 211/255 211/255)
|
||||
(define-rgb-color lightgray 211/255 211/255 211/255)
|
||||
(define-rgb-color midnightblue 5/51 5/51 112/255)
|
||||
(define-rgb-color navy 0 0 128/255)
|
||||
(define-rgb-color navyblue 0 0 128/255)
|
||||
(define-rgb-color cornflowerblue 20/51 149/255 79/85)
|
||||
(define-rgb-color darkslateblue 24/85 61/255 139/255)
|
||||
(define-rgb-color slateblue 106/255 6/17 41/51)
|
||||
(define-rgb-color mediumslateblue 41/85 104/255 14/15)
|
||||
(define-rgb-color lightslateblue 44/85 112/255 1)
|
||||
(define-rgb-color mediumblue 0 0 41/51)
|
||||
(define-rgb-color royalblue 13/51 7/17 15/17)
|
||||
(define-rgb-color blue 0 0 1)
|
||||
(define-rgb-color dodgerblue 2/17 48/85 1)
|
||||
(define-rgb-color deepskyblue 0 191/255 1)
|
||||
(define-rgb-color skyblue 9/17 206/255 47/51)
|
||||
(define-rgb-color lightskyblue 9/17 206/255 50/51)
|
||||
(define-rgb-color steelblue 14/51 26/51 12/17)
|
||||
(define-rgb-color lightsteelblue 176/255 196/255 74/85)
|
||||
(define-rgb-color lightblue 173/255 72/85 46/51)
|
||||
(define-rgb-color powderblue 176/255 224/255 46/51)
|
||||
(define-rgb-color paleturquoise 35/51 14/15 14/15)
|
||||
(define-rgb-color darkturquoise 0 206/255 209/255)
|
||||
(define-rgb-color mediumturquoise 24/85 209/255 4/5)
|
||||
(define-rgb-color turquoise 64/255 224/255 208/255)
|
||||
(define-rgb-color cyan 0 1 1)
|
||||
(define-rgb-color lightcyan 224/255 1 1)
|
||||
(define-rgb-color cadetblue 19/51 158/255 32/51)
|
||||
(define-rgb-color mediumaquamarine 2/5 41/51 2/3)
|
||||
(define-rgb-color aquamarine 127/255 1 212/255)
|
||||
(define-rgb-color darkgreen 0 20/51 0)
|
||||
(define-rgb-color darkolivegreen 1/3 107/255 47/255)
|
||||
(define-rgb-color darkseagreen 143/255 188/255 143/255)
|
||||
(define-rgb-color seagreen 46/255 139/255 29/85)
|
||||
(define-rgb-color mediumseagreen 4/17 179/255 113/255)
|
||||
(define-rgb-color lightseagreen 32/255 178/255 2/3)
|
||||
(define-rgb-color palegreen 152/255 251/255 152/255)
|
||||
(define-rgb-color springgreen 0 1 127/255)
|
||||
(define-rgb-color lawngreen 124/255 84/85 0)
|
||||
(define-rgb-color green 0 1 0)
|
||||
(define-rgb-color chartreuse 127/255 1 0)
|
||||
(define-rgb-color mediumspringgreen 0 50/51 154/255)
|
||||
(define-rgb-color greenyellow 173/255 1 47/255)
|
||||
(define-rgb-color limegreen 10/51 41/51 10/51)
|
||||
(define-rgb-color yellowgreen 154/255 41/51 10/51)
|
||||
(define-rgb-color forestgreen 2/15 139/255 2/15)
|
||||
(define-rgb-color olivedrab 107/255 142/255 7/51)
|
||||
(define-rgb-color darkkhaki 63/85 61/85 107/255)
|
||||
(define-rgb-color khaki 16/17 46/51 28/51)
|
||||
(define-rgb-color palegoldenrod 14/15 232/255 2/3)
|
||||
(define-rgb-color lightgoldenrodyellow 50/51 50/51 14/17)
|
||||
(define-rgb-color lightyellow 1 1 224/255)
|
||||
(define-rgb-color yellow 1 1 0)
|
||||
(define-rgb-color gold 1 43/51 0)
|
||||
(define-rgb-color lightgoldenrod 14/15 13/15 26/51)
|
||||
(define-rgb-color goldenrod 218/255 11/17 32/255)
|
||||
(define-rgb-color darkgoldenrod 184/255 134/255 11/255)
|
||||
(define-rgb-color rosybrown 188/255 143/255 143/255)
|
||||
(define-rgb-color indianred 41/51 92/255 92/255)
|
||||
(define-rgb-color saddlebrown 139/255 23/85 19/255)
|
||||
(define-rgb-color sienna 32/51 82/255 3/17)
|
||||
(define-rgb-color peru 41/51 133/255 21/85)
|
||||
(define-rgb-color burlywood 74/85 184/255 9/17)
|
||||
(define-rgb-color beige 49/51 49/51 44/51)
|
||||
(define-rgb-color wheat 49/51 74/85 179/255)
|
||||
(define-rgb-color sandybrown 244/255 164/255 32/85)
|
||||
(define-rgb-color tan 14/17 12/17 28/51)
|
||||
(define-rgb-color chocolate 14/17 7/17 2/17)
|
||||
(define-rgb-color firebrick 178/255 2/15 2/15)
|
||||
(define-rgb-color brown 11/17 14/85 14/85)
|
||||
(define-rgb-color darksalmon 233/255 10/17 122/255)
|
||||
(define-rgb-color salmon 50/51 128/255 38/85)
|
||||
(define-rgb-color lightsalmon 1 32/51 122/255)
|
||||
(define-rgb-color orange 1 11/17 0)
|
||||
(define-rgb-color darkorange 1 28/51 0)
|
||||
(define-rgb-color coral 1 127/255 16/51)
|
||||
(define-rgb-color lightcoral 16/17 128/255 128/255)
|
||||
(define-rgb-color tomato 1 33/85 71/255)
|
||||
(define-rgb-color orangered 1 23/85 0)
|
||||
(define-rgb-color red 1 0 0)
|
||||
(define-rgb-color hotpink 1 7/17 12/17)
|
||||
(define-rgb-color deeppink 1 4/51 49/85)
|
||||
(define-rgb-color pink 1 64/85 203/255)
|
||||
(define-rgb-color lightpink 1 182/255 193/255)
|
||||
(define-rgb-color palevioletred 73/85 112/255 49/85)
|
||||
(define-rgb-color maroon 176/255 16/85 32/85)
|
||||
(define-rgb-color mediumvioletred 199/255 7/85 133/255)
|
||||
(define-rgb-color violetred 208/255 32/255 48/85)
|
||||
(define-rgb-color magenta 1 0 1)
|
||||
(define-rgb-color violet 14/15 26/51 14/15)
|
||||
(define-rgb-color plum 13/15 32/51 13/15)
|
||||
(define-rgb-color orchid 218/255 112/255 214/255)
|
||||
(define-rgb-color mediumorchid 62/85 1/3 211/255)
|
||||
(define-rgb-color darkorchid 3/5 10/51 4/5)
|
||||
(define-rgb-color darkviolet 148/255 0 211/255)
|
||||
(define-rgb-color blueviolet 46/85 43/255 226/255)
|
||||
(define-rgb-color purple 32/51 32/255 16/17)
|
||||
(define-rgb-color mediumpurple 49/85 112/255 73/85)
|
||||
(define-rgb-color thistle 72/85 191/255 72/85)
|
||||
(define-rgb-color snow1 1 50/51 50/51)
|
||||
(define-rgb-color snow2 14/15 233/255 233/255)
|
||||
(define-rgb-color snow3 41/51 67/85 67/85)
|
||||
(define-rgb-color snow4 139/255 137/255 137/255)
|
||||
(define-rgb-color seashell1 1 49/51 14/15)
|
||||
(define-rgb-color seashell2 14/15 229/255 74/85)
|
||||
(define-rgb-color seashell3 41/51 197/255 191/255)
|
||||
(define-rgb-color seashell4 139/255 134/255 26/51)
|
||||
(define-rgb-color antiquewhite1 1 239/255 73/85)
|
||||
(define-rgb-color antiquewhite2 14/15 223/255 4/5)
|
||||
(define-rgb-color antiquewhite3 41/51 64/85 176/255)
|
||||
(define-rgb-color antiquewhite4 139/255 131/255 8/17)
|
||||
(define-rgb-color bisque1 1 76/85 196/255)
|
||||
(define-rgb-color bisque2 14/15 71/85 61/85)
|
||||
(define-rgb-color bisque3 41/51 61/85 158/255)
|
||||
(define-rgb-color bisque4 139/255 25/51 107/255)
|
||||
(define-rgb-color peachpuff1 1 218/255 37/51)
|
||||
(define-rgb-color peachpuff2 14/15 203/255 173/255)
|
||||
(define-rgb-color peachpuff3 41/51 35/51 149/255)
|
||||
(define-rgb-color peachpuff4 139/255 7/15 101/255)
|
||||
(define-rgb-color navajowhite1 1 74/85 173/255)
|
||||
(define-rgb-color navajowhite2 14/15 69/85 161/255)
|
||||
(define-rgb-color navajowhite3 41/51 179/255 139/255)
|
||||
(define-rgb-color navajowhite4 139/255 121/255 94/255)
|
||||
(define-rgb-color lemonchiffon1 1 50/51 41/51)
|
||||
(define-rgb-color lemonchiffon2 14/15 233/255 191/255)
|
||||
(define-rgb-color lemonchiffon3 41/51 67/85 11/17)
|
||||
(define-rgb-color lemonchiffon4 139/255 137/255 112/255)
|
||||
(define-rgb-color cornsilk1 1 248/255 44/51)
|
||||
(define-rgb-color cornsilk2 14/15 232/255 41/51)
|
||||
(define-rgb-color cornsilk3 41/51 40/51 59/85)
|
||||
(define-rgb-color cornsilk4 139/255 8/15 8/17)
|
||||
(define-rgb-color ivory1 1 1 16/17)
|
||||
(define-rgb-color ivory2 14/15 14/15 224/255)
|
||||
(define-rgb-color ivory3 41/51 41/51 193/255)
|
||||
(define-rgb-color ivory4 139/255 139/255 131/255)
|
||||
(define-rgb-color honeydew1 16/17 1 16/17)
|
||||
(define-rgb-color honeydew2 224/255 14/15 224/255)
|
||||
(define-rgb-color honeydew3 193/255 41/51 193/255)
|
||||
(define-rgb-color honeydew4 131/255 139/255 131/255)
|
||||
(define-rgb-color lavenderblush1 1 16/17 49/51)
|
||||
(define-rgb-color lavenderblush2 14/15 224/255 229/255)
|
||||
(define-rgb-color lavenderblush3 41/51 193/255 197/255)
|
||||
(define-rgb-color lavenderblush4 139/255 131/255 134/255)
|
||||
(define-rgb-color mistyrose1 1 76/85 15/17)
|
||||
(define-rgb-color mistyrose2 14/15 71/85 14/17)
|
||||
(define-rgb-color mistyrose3 41/51 61/85 181/255)
|
||||
(define-rgb-color mistyrose4 139/255 25/51 41/85)
|
||||
(define-rgb-color azure1 16/17 1 1)
|
||||
(define-rgb-color azure2 224/255 14/15 14/15)
|
||||
(define-rgb-color azure3 193/255 41/51 41/51)
|
||||
(define-rgb-color azure4 131/255 139/255 139/255)
|
||||
(define-rgb-color slateblue1 131/255 37/85 1)
|
||||
(define-rgb-color slateblue2 122/255 103/255 14/15)
|
||||
(define-rgb-color slateblue3 7/17 89/255 41/51)
|
||||
(define-rgb-color slateblue4 71/255 4/17 139/255)
|
||||
(define-rgb-color royalblue1 24/85 118/255 1)
|
||||
(define-rgb-color royalblue2 67/255 22/51 14/15)
|
||||
(define-rgb-color royalblue3 58/255 19/51 41/51)
|
||||
(define-rgb-color royalblue4 13/85 64/255 139/255)
|
||||
(define-rgb-color blue1 0 0 1)
|
||||
(define-rgb-color blue2 0 0 14/15)
|
||||
(define-rgb-color blue3 0 0 41/51)
|
||||
(define-rgb-color blue4 0 0 139/255)
|
||||
(define-rgb-color dodgerblue1 2/17 48/85 1)
|
||||
(define-rgb-color dodgerblue2 28/255 134/255 14/15)
|
||||
(define-rgb-color dodgerblue3 8/85 116/255 41/51)
|
||||
(define-rgb-color dodgerblue4 16/255 26/85 139/255)
|
||||
(define-rgb-color steelblue1 33/85 184/255 1)
|
||||
(define-rgb-color steelblue2 92/255 172/255 14/15)
|
||||
(define-rgb-color steelblue3 79/255 148/255 41/51)
|
||||
(define-rgb-color steelblue4 18/85 20/51 139/255)
|
||||
(define-rgb-color deepskyblue1 0 191/255 1)
|
||||
(define-rgb-color deepskyblue2 0 178/255 14/15)
|
||||
(define-rgb-color deepskyblue3 0 154/255 41/51)
|
||||
(define-rgb-color deepskyblue4 0 104/255 139/255)
|
||||
(define-rgb-color skyblue1 9/17 206/255 1)
|
||||
(define-rgb-color skyblue2 42/85 64/85 14/15)
|
||||
(define-rgb-color skyblue3 36/85 166/255 41/51)
|
||||
(define-rgb-color skyblue4 74/255 112/255 139/255)
|
||||
(define-rgb-color lightskyblue1 176/255 226/255 1)
|
||||
(define-rgb-color lightskyblue2 164/255 211/255 14/15)
|
||||
(define-rgb-color lightskyblue3 47/85 182/255 41/51)
|
||||
(define-rgb-color lightskyblue4 32/85 41/85 139/255)
|
||||
(define-rgb-color slategray1 66/85 226/255 1)
|
||||
(define-rgb-color slategray2 37/51 211/255 14/15)
|
||||
(define-rgb-color slategray3 53/85 182/255 41/51)
|
||||
(define-rgb-color slategray4 36/85 41/85 139/255)
|
||||
(define-rgb-color lightsteelblue1 202/255 15/17 1)
|
||||
(define-rgb-color lightsteelblue2 188/255 14/17 14/15)
|
||||
(define-rgb-color lightsteelblue3 54/85 181/255 41/51)
|
||||
(define-rgb-color lightsteelblue4 22/51 41/85 139/255)
|
||||
(define-rgb-color lightblue1 191/255 239/255 1)
|
||||
(define-rgb-color lightblue2 178/255 223/255 14/15)
|
||||
(define-rgb-color lightblue3 154/255 64/85 41/51)
|
||||
(define-rgb-color lightblue4 104/255 131/255 139/255)
|
||||
(define-rgb-color lightcyan1 224/255 1 1)
|
||||
(define-rgb-color lightcyan2 209/255 14/15 14/15)
|
||||
(define-rgb-color lightcyan3 12/17 41/51 41/51)
|
||||
(define-rgb-color lightcyan4 122/255 139/255 139/255)
|
||||
(define-rgb-color paleturquoise1 11/15 1 1)
|
||||
(define-rgb-color paleturquoise2 58/85 14/15 14/15)
|
||||
(define-rgb-color paleturquoise3 10/17 41/51 41/51)
|
||||
(define-rgb-color paleturquoise4 2/5 139/255 139/255)
|
||||
(define-rgb-color cadetblue1 152/255 49/51 1)
|
||||
(define-rgb-color cadetblue2 142/255 229/255 14/15)
|
||||
(define-rgb-color cadetblue3 122/255 197/255 41/51)
|
||||
(define-rgb-color cadetblue4 83/255 134/255 139/255)
|
||||
(define-rgb-color turquoise1 0 49/51 1)
|
||||
(define-rgb-color turquoise2 0 229/255 14/15)
|
||||
(define-rgb-color turquoise3 0 197/255 41/51)
|
||||
(define-rgb-color turquoise4 0 134/255 139/255)
|
||||
(define-rgb-color cyan1 0 1 1)
|
||||
(define-rgb-color cyan2 0 14/15 14/15)
|
||||
(define-rgb-color cyan3 0 41/51 41/51)
|
||||
(define-rgb-color cyan4 0 139/255 139/255)
|
||||
(define-rgb-color darkslategray1 151/255 1 1)
|
||||
(define-rgb-color darkslategray2 47/85 14/15 14/15)
|
||||
(define-rgb-color darkslategray3 121/255 41/51 41/51)
|
||||
(define-rgb-color darkslategray4 82/255 139/255 139/255)
|
||||
(define-rgb-color aquamarine1 127/255 1 212/255)
|
||||
(define-rgb-color aquamarine2 118/255 14/15 66/85)
|
||||
(define-rgb-color aquamarine3 2/5 41/51 2/3)
|
||||
(define-rgb-color aquamarine4 23/85 139/255 116/255)
|
||||
(define-rgb-color darkseagreen1 193/255 1 193/255)
|
||||
(define-rgb-color darkseagreen2 12/17 14/15 12/17)
|
||||
(define-rgb-color darkseagreen3 31/51 41/51 31/51)
|
||||
(define-rgb-color darkseagreen4 7/17 139/255 7/17)
|
||||
(define-rgb-color seagreen1 28/85 1 53/85)
|
||||
(define-rgb-color seagreen2 26/85 14/15 148/255)
|
||||
(define-rgb-color seagreen3 67/255 41/51 128/255)
|
||||
(define-rgb-color seagreen4 46/255 139/255 29/85)
|
||||
(define-rgb-color palegreen1 154/255 1 154/255)
|
||||
(define-rgb-color palegreen2 48/85 14/15 48/85)
|
||||
(define-rgb-color palegreen3 124/255 41/51 124/255)
|
||||
(define-rgb-color palegreen4 28/85 139/255 28/85)
|
||||
(define-rgb-color springgreen1 0 1 127/255)
|
||||
(define-rgb-color springgreen2 0 14/15 118/255)
|
||||
(define-rgb-color springgreen3 0 41/51 2/5)
|
||||
(define-rgb-color springgreen4 0 139/255 23/85)
|
||||
(define-rgb-color green1 0 1 0)
|
||||
(define-rgb-color green2 0 14/15 0)
|
||||
(define-rgb-color green3 0 41/51 0)
|
||||
(define-rgb-color green4 0 139/255 0)
|
||||
(define-rgb-color chartreuse1 127/255 1 0)
|
||||
(define-rgb-color chartreuse2 118/255 14/15 0)
|
||||
(define-rgb-color chartreuse3 2/5 41/51 0)
|
||||
(define-rgb-color chartreuse4 23/85 139/255 0)
|
||||
(define-rgb-color olivedrab1 64/85 1 62/255)
|
||||
(define-rgb-color olivedrab2 179/255 14/15 58/255)
|
||||
(define-rgb-color olivedrab3 154/255 41/51 10/51)
|
||||
(define-rgb-color olivedrab4 7/17 139/255 2/15)
|
||||
(define-rgb-color darkolivegreen1 202/255 1 112/255)
|
||||
(define-rgb-color darkolivegreen2 188/255 14/15 104/255)
|
||||
(define-rgb-color darkolivegreen3 54/85 41/51 6/17)
|
||||
(define-rgb-color darkolivegreen4 22/51 139/255 61/255)
|
||||
(define-rgb-color khaki1 1 82/85 143/255)
|
||||
(define-rgb-color khaki2 14/15 46/51 133/255)
|
||||
(define-rgb-color khaki3 41/51 66/85 23/51)
|
||||
(define-rgb-color khaki4 139/255 134/255 26/85)
|
||||
(define-rgb-color lightgoldenrod1 1 236/255 139/255)
|
||||
(define-rgb-color lightgoldenrod2 14/15 44/51 26/51)
|
||||
(define-rgb-color lightgoldenrod3 41/51 38/51 112/255)
|
||||
(define-rgb-color lightgoldenrod4 139/255 43/85 76/255)
|
||||
(define-rgb-color lightyellow1 1 1 224/255)
|
||||
(define-rgb-color lightyellow2 14/15 14/15 209/255)
|
||||
(define-rgb-color lightyellow3 41/51 41/51 12/17)
|
||||
(define-rgb-color lightyellow4 139/255 139/255 122/255)
|
||||
(define-rgb-color yellow1 1 1 0)
|
||||
(define-rgb-color yellow2 14/15 14/15 0)
|
||||
(define-rgb-color yellow3 41/51 41/51 0)
|
||||
(define-rgb-color yellow4 139/255 139/255 0)
|
||||
(define-rgb-color gold1 1 43/51 0)
|
||||
(define-rgb-color gold2 14/15 67/85 0)
|
||||
(define-rgb-color gold3 41/51 173/255 0)
|
||||
(define-rgb-color gold4 139/255 39/85 0)
|
||||
(define-rgb-color goldenrod1 1 193/255 37/255)
|
||||
(define-rgb-color goldenrod2 14/15 12/17 2/15)
|
||||
(define-rgb-color goldenrod3 41/51 31/51 29/255)
|
||||
(define-rgb-color goldenrod4 139/255 7/17 4/51)
|
||||
(define-rgb-color darkgoldenrod1 1 37/51 1/17)
|
||||
(define-rgb-color darkgoldenrod2 14/15 173/255 14/255)
|
||||
(define-rgb-color darkgoldenrod3 41/51 149/255 4/85)
|
||||
(define-rgb-color darkgoldenrod4 139/255 101/255 8/255)
|
||||
(define-rgb-color rosybrown1 1 193/255 193/255)
|
||||
(define-rgb-color rosybrown2 14/15 12/17 12/17)
|
||||
(define-rgb-color rosybrown3 41/51 31/51 31/51)
|
||||
(define-rgb-color rosybrown4 139/255 7/17 7/17)
|
||||
(define-rgb-color indianred1 1 106/255 106/255)
|
||||
(define-rgb-color indianred2 14/15 33/85 33/85)
|
||||
(define-rgb-color indianred3 41/51 1/3 1/3)
|
||||
(define-rgb-color indianred4 139/255 58/255 58/255)
|
||||
(define-rgb-color sienna1 1 26/51 71/255)
|
||||
(define-rgb-color sienna2 14/15 121/255 22/85)
|
||||
(define-rgb-color sienna3 41/51 104/255 19/85)
|
||||
(define-rgb-color sienna4 139/255 71/255 38/255)
|
||||
(define-rgb-color burlywood1 1 211/255 31/51)
|
||||
(define-rgb-color burlywood2 14/15 197/255 29/51)
|
||||
(define-rgb-color burlywood3 41/51 2/3 25/51)
|
||||
(define-rgb-color burlywood4 139/255 23/51 1/3)
|
||||
(define-rgb-color wheat1 1 77/85 62/85)
|
||||
(define-rgb-color wheat2 14/15 72/85 58/85)
|
||||
(define-rgb-color wheat3 41/51 62/85 10/17)
|
||||
(define-rgb-color wheat4 139/255 42/85 2/5)
|
||||
(define-rgb-color tan1 1 11/17 79/255)
|
||||
(define-rgb-color tan2 14/15 154/255 73/255)
|
||||
(define-rgb-color tan3 41/51 133/255 21/85)
|
||||
(define-rgb-color tan4 139/255 6/17 43/255)
|
||||
(define-rgb-color chocolate1 1 127/255 12/85)
|
||||
(define-rgb-color chocolate2 14/15 118/255 11/85)
|
||||
(define-rgb-color chocolate3 41/51 2/5 29/255)
|
||||
(define-rgb-color chocolate4 139/255 23/85 19/255)
|
||||
(define-rgb-color firebrick1 1 16/85 16/85)
|
||||
(define-rgb-color firebrick2 14/15 44/255 44/255)
|
||||
(define-rgb-color firebrick3 41/51 38/255 38/255)
|
||||
(define-rgb-color firebrick4 139/255 26/255 26/255)
|
||||
(define-rgb-color brown1 1 64/255 64/255)
|
||||
(define-rgb-color brown2 14/15 59/255 59/255)
|
||||
(define-rgb-color brown3 41/51 1/5 1/5)
|
||||
(define-rgb-color brown4 139/255 7/51 7/51)
|
||||
(define-rgb-color salmon1 1 28/51 7/17)
|
||||
(define-rgb-color salmon2 14/15 26/51 98/255)
|
||||
(define-rgb-color salmon3 41/51 112/255 28/85)
|
||||
(define-rgb-color salmon4 139/255 76/255 19/85)
|
||||
(define-rgb-color lightsalmon1 1 32/51 122/255)
|
||||
(define-rgb-color lightsalmon2 14/15 149/255 38/85)
|
||||
(define-rgb-color lightsalmon3 41/51 43/85 98/255)
|
||||
(define-rgb-color lightsalmon4 139/255 29/85 22/85)
|
||||
(define-rgb-color orange1 1 11/17 0)
|
||||
(define-rgb-color orange2 14/15 154/255 0)
|
||||
(define-rgb-color orange3 41/51 133/255 0)
|
||||
(define-rgb-color orange4 139/255 6/17 0)
|
||||
(define-rgb-color darkorange1 1 127/255 0)
|
||||
(define-rgb-color darkorange2 14/15 118/255 0)
|
||||
(define-rgb-color darkorange3 41/51 2/5 0)
|
||||
(define-rgb-color darkorange4 139/255 23/85 0)
|
||||
(define-rgb-color coral1 1 38/85 86/255)
|
||||
(define-rgb-color coral2 14/15 106/255 16/51)
|
||||
(define-rgb-color coral3 41/51 91/255 23/85)
|
||||
(define-rgb-color coral4 139/255 62/255 47/255)
|
||||
(define-rgb-color tomato1 1 33/85 71/255)
|
||||
(define-rgb-color tomato2 14/15 92/255 22/85)
|
||||
(define-rgb-color tomato3 41/51 79/255 19/85)
|
||||
(define-rgb-color tomato4 139/255 18/85 38/255)
|
||||
(define-rgb-color orangered1 1 23/85 0)
|
||||
(define-rgb-color orangered2 14/15 64/255 0)
|
||||
(define-rgb-color orangered3 41/51 11/51 0)
|
||||
(define-rgb-color orangered4 139/255 37/255 0)
|
||||
(define-rgb-color red1 1 0 0)
|
||||
(define-rgb-color red2 14/15 0 0)
|
||||
(define-rgb-color red3 41/51 0 0)
|
||||
(define-rgb-color red4 139/255 0 0)
|
||||
(define-rgb-color debianred 43/51 7/255 27/85)
|
||||
(define-rgb-color deeppink1 1 4/51 49/85)
|
||||
(define-rgb-color deeppink2 14/15 6/85 137/255)
|
||||
(define-rgb-color deeppink3 41/51 16/255 118/255)
|
||||
(define-rgb-color deeppink4 139/255 2/51 16/51)
|
||||
(define-rgb-color hotpink1 1 22/51 12/17)
|
||||
(define-rgb-color hotpink2 14/15 106/255 167/255)
|
||||
(define-rgb-color hotpink3 41/51 32/85 48/85)
|
||||
(define-rgb-color hotpink4 139/255 58/255 98/255)
|
||||
(define-rgb-color pink1 1 181/255 197/255)
|
||||
(define-rgb-color pink2 14/15 169/255 184/255)
|
||||
(define-rgb-color pink3 41/51 29/51 158/255)
|
||||
(define-rgb-color pink4 139/255 33/85 36/85)
|
||||
(define-rgb-color lightpink1 1 58/85 37/51)
|
||||
(define-rgb-color lightpink2 14/15 54/85 173/255)
|
||||
(define-rgb-color lightpink3 41/51 28/51 149/255)
|
||||
(define-rgb-color lightpink4 139/255 19/51 101/255)
|
||||
(define-rgb-color palevioletred1 1 26/51 57/85)
|
||||
(define-rgb-color palevioletred2 14/15 121/255 53/85)
|
||||
(define-rgb-color palevioletred3 41/51 104/255 137/255)
|
||||
(define-rgb-color palevioletred4 139/255 71/255 31/85)
|
||||
(define-rgb-color maroon1 1 52/255 179/255)
|
||||
(define-rgb-color maroon2 14/15 16/85 167/255)
|
||||
(define-rgb-color maroon3 41/51 41/255 48/85)
|
||||
(define-rgb-color maroon4 139/255 28/255 98/255)
|
||||
(define-rgb-color violetred1 1 62/255 10/17)
|
||||
(define-rgb-color violetred2 14/15 58/255 28/51)
|
||||
(define-rgb-color violetred3 41/51 10/51 8/17)
|
||||
(define-rgb-color violetred4 139/255 2/15 82/255)
|
||||
(define-rgb-color magenta1 1 0 1)
|
||||
(define-rgb-color magenta2 14/15 0 14/15)
|
||||
(define-rgb-color magenta3 41/51 0 41/51)
|
||||
(define-rgb-color magenta4 139/255 0 139/255)
|
||||
(define-rgb-color orchid1 1 131/255 50/51)
|
||||
(define-rgb-color orchid2 14/15 122/255 233/255)
|
||||
(define-rgb-color orchid3 41/51 7/17 67/85)
|
||||
(define-rgb-color orchid4 139/255 71/255 137/255)
|
||||
(define-rgb-color plum1 1 11/15 1)
|
||||
(define-rgb-color plum2 14/15 58/85 14/15)
|
||||
(define-rgb-color plum3 41/51 10/17 41/51)
|
||||
(define-rgb-color plum4 139/255 2/5 139/255)
|
||||
(define-rgb-color mediumorchid1 224/255 2/5 1)
|
||||
(define-rgb-color mediumorchid2 209/255 19/51 14/15)
|
||||
(define-rgb-color mediumorchid3 12/17 82/255 41/51)
|
||||
(define-rgb-color mediumorchid4 122/255 11/51 139/255)
|
||||
(define-rgb-color darkorchid1 191/255 62/255 1)
|
||||
(define-rgb-color darkorchid2 178/255 58/255 14/15)
|
||||
(define-rgb-color darkorchid3 154/255 10/51 41/51)
|
||||
(define-rgb-color darkorchid4 104/255 2/15 139/255)
|
||||
(define-rgb-color purple1 31/51 16/85 1)
|
||||
(define-rgb-color purple2 29/51 44/255 14/15)
|
||||
(define-rgb-color purple3 25/51 38/255 41/51)
|
||||
(define-rgb-color purple4 1/3 26/255 139/255)
|
||||
(define-rgb-color mediumpurple1 57/85 26/51 1)
|
||||
(define-rgb-color mediumpurple2 53/85 121/255 14/15)
|
||||
(define-rgb-color mediumpurple3 137/255 104/255 41/51)
|
||||
(define-rgb-color mediumpurple4 31/85 71/255 139/255)
|
||||
(define-rgb-color thistle1 1 15/17 1)
|
||||
(define-rgb-color thistle2 14/15 14/17 14/15)
|
||||
(define-rgb-color thistle3 41/51 181/255 41/51)
|
||||
(define-rgb-color thistle4 139/255 41/85 139/255)
|
||||
(define-rgb-color gray0 0 0 0)
|
||||
(define-rgb-color grey0 0 0 0)
|
||||
(define-rgb-color gray1 1/85 1/85 1/85)
|
||||
(define-rgb-color grey1 1/85 1/85 1/85)
|
||||
(define-rgb-color gray2 1/51 1/51 1/51)
|
||||
(define-rgb-color grey2 1/51 1/51 1/51)
|
||||
(define-rgb-color gray3 8/255 8/255 8/255)
|
||||
(define-rgb-color grey3 8/255 8/255 8/255)
|
||||
(define-rgb-color gray4 2/51 2/51 2/51)
|
||||
(define-rgb-color grey4 2/51 2/51 2/51)
|
||||
(define-rgb-color gray5 13/255 13/255 13/255)
|
||||
(define-rgb-color grey5 13/255 13/255 13/255)
|
||||
(define-rgb-color gray6 1/17 1/17 1/17)
|
||||
(define-rgb-color grey6 1/17 1/17 1/17)
|
||||
(define-rgb-color gray7 6/85 6/85 6/85)
|
||||
(define-rgb-color grey7 6/85 6/85 6/85)
|
||||
(define-rgb-color gray8 4/51 4/51 4/51)
|
||||
(define-rgb-color grey8 4/51 4/51 4/51)
|
||||
(define-rgb-color gray9 23/255 23/255 23/255)
|
||||
(define-rgb-color grey9 23/255 23/255 23/255)
|
||||
(define-rgb-color gray10 26/255 26/255 26/255)
|
||||
(define-rgb-color grey10 26/255 26/255 26/255)
|
||||
(define-rgb-color gray11 28/255 28/255 28/255)
|
||||
(define-rgb-color grey11 28/255 28/255 28/255)
|
||||
(define-rgb-color gray12 31/255 31/255 31/255)
|
||||
(define-rgb-color grey12 31/255 31/255 31/255)
|
||||
(define-rgb-color gray13 11/85 11/85 11/85)
|
||||
(define-rgb-color grey13 11/85 11/85 11/85)
|
||||
(define-rgb-color gray14 12/85 12/85 12/85)
|
||||
(define-rgb-color grey14 12/85 12/85 12/85)
|
||||
(define-rgb-color gray15 38/255 38/255 38/255)
|
||||
(define-rgb-color grey15 38/255 38/255 38/255)
|
||||
(define-rgb-color gray16 41/255 41/255 41/255)
|
||||
(define-rgb-color grey16 41/255 41/255 41/255)
|
||||
(define-rgb-color gray17 43/255 43/255 43/255)
|
||||
(define-rgb-color grey17 43/255 43/255 43/255)
|
||||
(define-rgb-color gray18 46/255 46/255 46/255)
|
||||
(define-rgb-color grey18 46/255 46/255 46/255)
|
||||
(define-rgb-color gray19 16/85 16/85 16/85)
|
||||
(define-rgb-color grey19 16/85 16/85 16/85)
|
||||
(define-rgb-color gray20 1/5 1/5 1/5)
|
||||
(define-rgb-color grey20 1/5 1/5 1/5)
|
||||
(define-rgb-color gray21 18/85 18/85 18/85)
|
||||
(define-rgb-color grey21 18/85 18/85 18/85)
|
||||
(define-rgb-color gray22 56/255 56/255 56/255)
|
||||
(define-rgb-color grey22 56/255 56/255 56/255)
|
||||
(define-rgb-color gray23 59/255 59/255 59/255)
|
||||
(define-rgb-color grey23 59/255 59/255 59/255)
|
||||
(define-rgb-color gray24 61/255 61/255 61/255)
|
||||
(define-rgb-color grey24 61/255 61/255 61/255)
|
||||
(define-rgb-color gray25 64/255 64/255 64/255)
|
||||
(define-rgb-color grey25 64/255 64/255 64/255)
|
||||
(define-rgb-color gray26 22/85 22/85 22/85)
|
||||
(define-rgb-color grey26 22/85 22/85 22/85)
|
||||
(define-rgb-color gray27 23/85 23/85 23/85)
|
||||
(define-rgb-color grey27 23/85 23/85 23/85)
|
||||
(define-rgb-color gray28 71/255 71/255 71/255)
|
||||
(define-rgb-color grey28 71/255 71/255 71/255)
|
||||
(define-rgb-color gray29 74/255 74/255 74/255)
|
||||
(define-rgb-color grey29 74/255 74/255 74/255)
|
||||
(define-rgb-color gray30 77/255 77/255 77/255)
|
||||
(define-rgb-color grey30 77/255 77/255 77/255)
|
||||
(define-rgb-color gray31 79/255 79/255 79/255)
|
||||
(define-rgb-color grey31 79/255 79/255 79/255)
|
||||
(define-rgb-color gray32 82/255 82/255 82/255)
|
||||
(define-rgb-color grey32 82/255 82/255 82/255)
|
||||
(define-rgb-color gray33 28/85 28/85 28/85)
|
||||
(define-rgb-color grey33 28/85 28/85 28/85)
|
||||
(define-rgb-color gray34 29/85 29/85 29/85)
|
||||
(define-rgb-color grey34 29/85 29/85 29/85)
|
||||
(define-rgb-color gray35 89/255 89/255 89/255)
|
||||
(define-rgb-color grey35 89/255 89/255 89/255)
|
||||
(define-rgb-color gray36 92/255 92/255 92/255)
|
||||
(define-rgb-color grey36 92/255 92/255 92/255)
|
||||
(define-rgb-color gray37 94/255 94/255 94/255)
|
||||
(define-rgb-color grey37 94/255 94/255 94/255)
|
||||
(define-rgb-color gray38 97/255 97/255 97/255)
|
||||
(define-rgb-color grey38 97/255 97/255 97/255)
|
||||
(define-rgb-color gray39 33/85 33/85 33/85)
|
||||
(define-rgb-color grey39 33/85 33/85 33/85)
|
||||
(define-rgb-color gray40 2/5 2/5 2/5)
|
||||
(define-rgb-color grey40 2/5 2/5 2/5)
|
||||
(define-rgb-color gray41 7/17 7/17 7/17)
|
||||
(define-rgb-color grey41 7/17 7/17 7/17)
|
||||
(define-rgb-color gray42 107/255 107/255 107/255)
|
||||
(define-rgb-color grey42 107/255 107/255 107/255)
|
||||
(define-rgb-color gray43 22/51 22/51 22/51)
|
||||
(define-rgb-color grey43 22/51 22/51 22/51)
|
||||
(define-rgb-color gray44 112/255 112/255 112/255)
|
||||
(define-rgb-color grey44 112/255 112/255 112/255)
|
||||
(define-rgb-color gray45 23/51 23/51 23/51)
|
||||
(define-rgb-color grey45 23/51 23/51 23/51)
|
||||
(define-rgb-color gray46 39/85 39/85 39/85)
|
||||
(define-rgb-color grey46 39/85 39/85 39/85)
|
||||
(define-rgb-color gray47 8/17 8/17 8/17)
|
||||
(define-rgb-color grey47 8/17 8/17 8/17)
|
||||
(define-rgb-color gray48 122/255 122/255 122/255)
|
||||
(define-rgb-color grey48 122/255 122/255 122/255)
|
||||
(define-rgb-color gray49 25/51 25/51 25/51)
|
||||
(define-rgb-color grey49 25/51 25/51 25/51)
|
||||
(define-rgb-color gray50 127/255 127/255 127/255)
|
||||
(define-rgb-color grey50 127/255 127/255 127/255)
|
||||
(define-rgb-color gray51 26/51 26/51 26/51)
|
||||
(define-rgb-color grey51 26/51 26/51 26/51)
|
||||
(define-rgb-color gray52 133/255 133/255 133/255)
|
||||
(define-rgb-color grey52 133/255 133/255 133/255)
|
||||
(define-rgb-color gray53 9/17 9/17 9/17)
|
||||
(define-rgb-color grey53 9/17 9/17 9/17)
|
||||
(define-rgb-color gray54 46/85 46/85 46/85)
|
||||
(define-rgb-color grey54 46/85 46/85 46/85)
|
||||
(define-rgb-color gray55 28/51 28/51 28/51)
|
||||
(define-rgb-color grey55 28/51 28/51 28/51)
|
||||
(define-rgb-color gray56 143/255 143/255 143/255)
|
||||
(define-rgb-color grey56 143/255 143/255 143/255)
|
||||
(define-rgb-color gray57 29/51 29/51 29/51)
|
||||
(define-rgb-color grey57 29/51 29/51 29/51)
|
||||
(define-rgb-color gray58 148/255 148/255 148/255)
|
||||
(define-rgb-color grey58 148/255 148/255 148/255)
|
||||
(define-rgb-color gray59 10/17 10/17 10/17)
|
||||
(define-rgb-color grey59 10/17 10/17 10/17)
|
||||
(define-rgb-color gray60 3/5 3/5 3/5)
|
||||
(define-rgb-color grey60 3/5 3/5 3/5)
|
||||
(define-rgb-color gray61 52/85 52/85 52/85)
|
||||
(define-rgb-color grey61 52/85 52/85 52/85)
|
||||
(define-rgb-color gray62 158/255 158/255 158/255)
|
||||
(define-rgb-color grey62 158/255 158/255 158/255)
|
||||
(define-rgb-color gray63 161/255 161/255 161/255)
|
||||
(define-rgb-color grey63 161/255 161/255 161/255)
|
||||
(define-rgb-color gray64 163/255 163/255 163/255)
|
||||
(define-rgb-color grey64 163/255 163/255 163/255)
|
||||
(define-rgb-color gray65 166/255 166/255 166/255)
|
||||
(define-rgb-color grey65 166/255 166/255 166/255)
|
||||
(define-rgb-color gray66 56/85 56/85 56/85)
|
||||
(define-rgb-color grey66 56/85 56/85 56/85)
|
||||
(define-rgb-color gray67 57/85 57/85 57/85)
|
||||
(define-rgb-color grey67 57/85 57/85 57/85)
|
||||
(define-rgb-color gray68 173/255 173/255 173/255)
|
||||
(define-rgb-color grey68 173/255 173/255 173/255)
|
||||
(define-rgb-color gray69 176/255 176/255 176/255)
|
||||
(define-rgb-color grey69 176/255 176/255 176/255)
|
||||
(define-rgb-color gray70 179/255 179/255 179/255)
|
||||
(define-rgb-color grey70 179/255 179/255 179/255)
|
||||
(define-rgb-color gray71 181/255 181/255 181/255)
|
||||
(define-rgb-color grey71 181/255 181/255 181/255)
|
||||
(define-rgb-color gray72 184/255 184/255 184/255)
|
||||
(define-rgb-color grey72 184/255 184/255 184/255)
|
||||
(define-rgb-color gray73 62/85 62/85 62/85)
|
||||
(define-rgb-color grey73 62/85 62/85 62/85)
|
||||
(define-rgb-color gray74 63/85 63/85 63/85)
|
||||
(define-rgb-color grey74 63/85 63/85 63/85)
|
||||
(define-rgb-color gray75 191/255 191/255 191/255)
|
||||
(define-rgb-color grey75 191/255 191/255 191/255)
|
||||
(define-rgb-color gray76 194/255 194/255 194/255)
|
||||
(define-rgb-color grey76 194/255 194/255 194/255)
|
||||
(define-rgb-color gray77 196/255 196/255 196/255)
|
||||
(define-rgb-color grey77 196/255 196/255 196/255)
|
||||
(define-rgb-color gray78 199/255 199/255 199/255)
|
||||
(define-rgb-color grey78 199/255 199/255 199/255)
|
||||
(define-rgb-color gray79 67/85 67/85 67/85)
|
||||
(define-rgb-color grey79 67/85 67/85 67/85)
|
||||
(define-rgb-color gray80 4/5 4/5 4/5)
|
||||
(define-rgb-color grey80 4/5 4/5 4/5)
|
||||
(define-rgb-color gray81 69/85 69/85 69/85)
|
||||
(define-rgb-color grey81 69/85 69/85 69/85)
|
||||
(define-rgb-color gray82 209/255 209/255 209/255)
|
||||
(define-rgb-color grey82 209/255 209/255 209/255)
|
||||
(define-rgb-color gray83 212/255 212/255 212/255)
|
||||
(define-rgb-color grey83 212/255 212/255 212/255)
|
||||
(define-rgb-color gray84 214/255 214/255 214/255)
|
||||
(define-rgb-color grey84 214/255 214/255 214/255)
|
||||
(define-rgb-color gray85 217/255 217/255 217/255)
|
||||
(define-rgb-color grey85 217/255 217/255 217/255)
|
||||
(define-rgb-color gray86 73/85 73/85 73/85)
|
||||
(define-rgb-color grey86 73/85 73/85 73/85)
|
||||
(define-rgb-color gray87 74/85 74/85 74/85)
|
||||
(define-rgb-color grey87 74/85 74/85 74/85)
|
||||
(define-rgb-color gray88 224/255 224/255 224/255)
|
||||
(define-rgb-color grey88 224/255 224/255 224/255)
|
||||
(define-rgb-color gray89 227/255 227/255 227/255)
|
||||
(define-rgb-color grey89 227/255 227/255 227/255)
|
||||
(define-rgb-color gray90 229/255 229/255 229/255)
|
||||
(define-rgb-color grey90 229/255 229/255 229/255)
|
||||
(define-rgb-color gray91 232/255 232/255 232/255)
|
||||
(define-rgb-color grey91 232/255 232/255 232/255)
|
||||
(define-rgb-color gray92 47/51 47/51 47/51)
|
||||
(define-rgb-color grey92 47/51 47/51 47/51)
|
||||
(define-rgb-color gray93 79/85 79/85 79/85)
|
||||
(define-rgb-color grey93 79/85 79/85 79/85)
|
||||
(define-rgb-color gray94 16/17 16/17 16/17)
|
||||
(define-rgb-color grey94 16/17 16/17 16/17)
|
||||
(define-rgb-color gray95 242/255 242/255 242/255)
|
||||
(define-rgb-color grey95 242/255 242/255 242/255)
|
||||
(define-rgb-color gray96 49/51 49/51 49/51)
|
||||
(define-rgb-color grey96 49/51 49/51 49/51)
|
||||
(define-rgb-color gray97 247/255 247/255 247/255)
|
||||
(define-rgb-color grey97 247/255 247/255 247/255)
|
||||
(define-rgb-color gray98 50/51 50/51 50/51)
|
||||
(define-rgb-color grey98 50/51 50/51 50/51)
|
||||
(define-rgb-color gray99 84/85 84/85 84/85)
|
||||
(define-rgb-color grey99 84/85 84/85 84/85)
|
||||
(define-rgb-color gray100 1 1 1)
|
||||
(define-rgb-color grey100 1 1 1)
|
||||
(define-rgb-color darkgrey 169/255 169/255 169/255)
|
||||
(define-rgb-color darkgray 169/255 169/255 169/255)
|
||||
(define-rgb-color darkblue 0 0 139/255)
|
||||
(define-rgb-color darkcyan 0 139/255 139/255)
|
||||
(define-rgb-color darkmagenta 139/255 0 139/255)
|
||||
(define-rgb-color darkred 139/255 0 0)
|
||||
(define-rgb-color lightgreen 48/85 14/15 48/85)
|
||||
|
|
@ -0,0 +1,167 @@
|
|||
(in-package :cl-colors)
|
||||
|
||||
;;; color representations
|
||||
|
||||
(deftype unit-real ()
|
||||
"Real number in [0,1]."
|
||||
'(real 0 1))
|
||||
|
||||
(defstruct (rgb (:constructor rgb (red green blue)))
|
||||
"RGB color."
|
||||
(red nil :type unit-real :read-only t)
|
||||
(green nil :type unit-real :read-only t)
|
||||
(blue nil :type unit-real :read-only t))
|
||||
|
||||
(defmethod make-load-form ((p rgb) &optional env)
|
||||
(declare (ignore env))
|
||||
(make-load-form-saving-slots p))
|
||||
|
||||
(defun gray (value)
|
||||
"Create an RGB representation of a gray color (value in [0,1)."
|
||||
(rgb value value value))
|
||||
|
||||
(define-structure-let+ (rgb) red green blue)
|
||||
|
||||
(defstruct (hsv (:constructor hsv (hue saturation value)))
|
||||
"HSV color."
|
||||
(hue nil :type (real 0 360) :read-only t)
|
||||
(saturation nil :type unit-real :read-only t)
|
||||
(value nil :type unit-real :read-only t))
|
||||
|
||||
(defmethod make-load-form ((p hsv) &optional env)
|
||||
(declare (ignore env))
|
||||
(make-load-form-saving-slots p))
|
||||
|
||||
(define-structure-let+ (hsv) hue saturation value)
|
||||
|
||||
(defun normalize-hue (hue)
|
||||
"Normalize hue to the interval [0,360)."
|
||||
(mod hue 360))
|
||||
|
||||
;;; conversions
|
||||
|
||||
(defun rgb-to-hsv (rgb &optional (undefined-hue 0))
|
||||
"Convert RGB to HSV representation. When hue is undefined (saturation is
|
||||
zero), UNDEFINED-HUE will be assigned."
|
||||
(let+ (((&rgb red green blue) rgb)
|
||||
(value (max red green blue))
|
||||
(delta (- value (min red green blue)))
|
||||
(saturation (if (plusp value)
|
||||
(/ delta value)
|
||||
0))
|
||||
((&flet normalize (constant right left)
|
||||
(let ((hue (+ constant (/ (* 60 (- right left)) delta))))
|
||||
(if (minusp hue)
|
||||
(+ hue 360)
|
||||
hue)))))
|
||||
(hsv (cond
|
||||
((zerop saturation) undefined-hue) ; undefined
|
||||
((= red value) (normalize 0 green blue)) ; dominant red
|
||||
((= green value) (normalize 120 blue red)) ; dominant green
|
||||
(t (normalize 240 red green)))
|
||||
saturation
|
||||
value)))
|
||||
|
||||
(defun hsv-to-rgb (hsv)
|
||||
"Convert HSV to RGB representation. When SATURATION is zero, HUE is
|
||||
ignored."
|
||||
(let+ (((&hsv hue saturation value) hsv))
|
||||
;; if saturation=0, color is on the gray line
|
||||
(when (zerop saturation)
|
||||
(return-from hsv-to-rgb (gray value)))
|
||||
;; nonzero saturation: normalize hue to [0,6)
|
||||
(let+ ((h (/ (normalize-hue hue) 60))
|
||||
((&values quotient remainder) (floor h))
|
||||
(p (* value (- 1 saturation)))
|
||||
(q (* value (- 1 (* saturation remainder))))
|
||||
(r (* value (- 1 (* saturation (- 1 remainder)))))
|
||||
((&values red green blue) (case quotient
|
||||
(0 (values value r p))
|
||||
(1 (values q value p))
|
||||
(2 (values p value r))
|
||||
(3 (values p q value))
|
||||
(4 (values r p value))
|
||||
(t (values value p q)))))
|
||||
(rgb red green blue))))
|
||||
|
||||
(defun hex-to-rgb (string)
|
||||
"Parse hexadecimal notation (eg ff0000 or f00 for red) into an RGB color."
|
||||
(let+ (((&values width max)
|
||||
(case (length string)
|
||||
(3 (values 1 15))
|
||||
(6 (values 2 255))
|
||||
(t (error "string ~A doesn't have length 3 or 6, can't parse as ~
|
||||
RGB specification" string))))
|
||||
((&flet parse (index)
|
||||
(/ (parse-integer string :start (* index width)
|
||||
:end (* (1+ index) width)
|
||||
:radix 16)
|
||||
max))))
|
||||
(rgb (parse 0) (parse 1) (parse 2))))
|
||||
|
||||
|
||||
|
||||
;;; conversion with generic functions
|
||||
|
||||
(defgeneric as-hsv (color &optional undefined-hue)
|
||||
(:method ((color rgb) &optional (undefined-hue 0))
|
||||
(rgb-to-hsv color undefined-hue))
|
||||
(:method ((color hsv) &optional undefined-hue)
|
||||
(declare (ignore undefined-hue))
|
||||
color))
|
||||
|
||||
(defgeneric as-rgb (color)
|
||||
(:method ((rgb rgb))
|
||||
rgb)
|
||||
(:method ((hsv hsv))
|
||||
(hsv-to-rgb hsv))
|
||||
(:method ((string string))
|
||||
;; TODO in the long run this should recognize color names too
|
||||
(hex-to-rgb string)))
|
||||
|
||||
|
||||
|
||||
;;; combinations
|
||||
|
||||
;;; internal functions
|
||||
|
||||
(declaim (inline cc))
|
||||
(defun cc (a b alpha)
|
||||
"Convex combination (1-ALPHA)*A+ALPHA*B, ie ALPHA is the weight of A."
|
||||
(declare (type (real 0 1) alpha))
|
||||
(+ (* (- 1 alpha) a) (* alpha b)))
|
||||
|
||||
(defun rgb-combination (color1 color2 alpha)
|
||||
"Color combination in RGB space."
|
||||
(let+ (((&rgb red1 green1 blue1) (as-rgb color1))
|
||||
((&rgb red2 green2 blue2) (as-rgb color2))
|
||||
((&flet c (c1 c2) (cc c1 c2 alpha))))
|
||||
(rgb (c red1 red2)
|
||||
(c green1 green2)
|
||||
(c blue1 blue2))))
|
||||
|
||||
(defun hsv-combination (hsv1 hsv2 alpha &optional (positive? t))
|
||||
"Color combination in HSV space. POSITIVE? determines whether the hue
|
||||
combination is in the positive or negative direction on the color wheel."
|
||||
(let+ (((&hsv hue1 saturation1 value1) (as-hsv hsv1))
|
||||
((&hsv hue2 saturation2 value2) (as-hsv hsv2))
|
||||
((&flet c (c1 c2) (cc c1 c2 alpha))))
|
||||
(hsv (cond
|
||||
((and positive? (> hue1 hue2))
|
||||
(normalize-hue (c hue1 (+ hue2 360))))
|
||||
((and (not positive?) (< hue1 hue2))
|
||||
(normalize-hue (c (+ hue1 360) hue2)))
|
||||
(t (c hue1 hue2)))
|
||||
(c saturation1 saturation2)
|
||||
(c value1 value2))))
|
||||
|
||||
|
||||
|
||||
;;; macros used by the autogenerated files
|
||||
|
||||
(defmacro define-rgb-color (name red green blue)
|
||||
"Macro for defining color constants. Used by the automatically generated color file."
|
||||
(let ((constant-name (symbolicate #\+ name #\+)))
|
||||
`(progn
|
||||
(define-constant ,constant-name (rgb ,red ,green ,blue)
|
||||
:test #'equalp :documentation ,(format nil "X11 color ~A." name)))))
|
||||
|
|
@ -0,0 +1,69 @@
|
|||
(in-package #:cl-colors)
|
||||
|
||||
;;; parsing and printing of CSS-like colors
|
||||
|
||||
(defun print-hex-rgb (color &key short (hash T) alpha destination)
|
||||
"Converts a COLOR to its hexadecimal RGB string representation. If
|
||||
SHORT is specified each component gets just one character.
|
||||
|
||||
A hash character (#) is prepended if HASH is true (default).
|
||||
|
||||
If ALPHA is set it is included as an ALPHA component.
|
||||
|
||||
DESTINATION is the first argument to FORMAT, by default NIL."
|
||||
(let+ (((&rgb red green blue) (as-rgb color))
|
||||
(factor (if short 15 255))
|
||||
((&flet c (x) (round (* x factor)))))
|
||||
(format destination (if short
|
||||
"~@[~C~]~X~X~X~@[~X~]"
|
||||
"~@[~C~]~2,'0X~2,'0X~2,'0X~@[~X~]")
|
||||
(and hash #\#)
|
||||
(c red) (c green) (c blue)
|
||||
(and alpha (c alpha)))))
|
||||
|
||||
;; TODO: a JUNK-ALLOWED parameter, like for PARSE-INTEGER, would be nice
|
||||
(defun parse-hex-rgb (string &key (start 0) end)
|
||||
"Parses a hexadecimal RGB(A) color string. Returns a new RGB color value
|
||||
and an alpha component if present."
|
||||
(let* ((length (length string))
|
||||
(end (or end length))
|
||||
(sub-length (- end start)))
|
||||
(cond
|
||||
;; check for valid range, we need at least three and accept at most
|
||||
;; nine characters
|
||||
((and (<= #.(length "fff") sub-length)
|
||||
(<= sub-length #.(length "#ffffff00")))
|
||||
(when (char= (char string start) #\#)
|
||||
(incf start)
|
||||
(decf sub-length))
|
||||
(labels ((parse (string index offset)
|
||||
(parse-integer string :start index :end (+ offset index)
|
||||
:radix 16))
|
||||
(short (string index)
|
||||
(/ (parse string index 1) 15))
|
||||
(long (string index)
|
||||
(/ (parse string index 2) 255)))
|
||||
;; recognize possible combinations of alpha component and length
|
||||
;; of the rest of the encoded color
|
||||
(multiple-value-bind (shortp alphap)
|
||||
(case sub-length
|
||||
(#.(length "fff") (values T NIL))
|
||||
(#.(length "fff0") (values T T))
|
||||
(#.(length "ffffff") (values NIL NIL))
|
||||
(#.(length "ffffff00") (values NIL T)))
|
||||
(if shortp
|
||||
(values
|
||||
(rgb
|
||||
(short string start)
|
||||
(short string (+ 1 start))
|
||||
(short string (+ 2 start)))
|
||||
(and alphap (short string (+ 3 start))))
|
||||
(values
|
||||
(rgb
|
||||
(long string start)
|
||||
(long string (+ 2 start))
|
||||
(long string (+ 4 start)))
|
||||
(and alphap (long string (+ 6 start))))))))
|
||||
(T
|
||||
(error "not enough or too many characters in indicated sequence: ~A"
|
||||
(subseq string start end))))))
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
Color classes
|
||||
-------------
|
||||
|
||||
The two main color classes are rgb and hsv, which have slots red,
|
||||
green, blue and hue, saturation, value respectively. There is also an
|
||||
rgb class with an alpha channel (slot alpha) called rgba. In the rgb
|
||||
class, valid slot values are from 0 to 1, while in the hsv class,
|
||||
saturation and value are in the interval [0,1], but hue is in [0,360).
|
||||
|
||||
You can convert between rgb and hsv using rgb->hsv and hsv->rgb. Note
|
||||
that for the former, you need to specify what happens when the hue is
|
||||
undefined (ie the color is gray). By default, the hue of red (0) is
|
||||
assigned.
|
||||
|
||||
Generic functions which find the appropriate conversion method are
|
||||
available with names ->rgb and ->hsv. Use these if you want your
|
||||
functions to handle various different color representations but
|
||||
eventually you need to work with a single one.
|
||||
|
||||
|
||||
|
||||
Named colors
|
||||
------------
|
||||
|
||||
Named colors, parsed from the X11 colors file, are loaded from
|
||||
colornames.lisp. As they are constants, names are between +'s. All
|
||||
named colors are rgb.
|
||||
|
||||
|
||||
|
||||
Convex combinations
|
||||
-------------------
|
||||
|
||||
Use hsv-combination or rgb-combination for taking convex combinations
|
||||
in the respective color space. Note that in the HSV space, you need
|
||||
to specify the direction on the color wheel, the default is positive.
|
||||
|
||||
|
||||
Example session
|
||||
---------------
|
||||
|
||||
CL-COLORS> +blue+
|
||||
#<RGB red: 0.0d0 green: 0.0d0 blue: 1.0d0>
|
||||
CL-COLORS> (->hsv +blue+)
|
||||
#<HSV hue: 240.0d0 saturation: 1.0d0 value: 1.0d0>
|
||||
CL-COLORS> (rgb-combination +blue+ +green+ 0.5)
|
||||
#<RGB red: 0.0d0 green: 0.5d0 blue: 0.5d0>
|
||||
CL-COLORS> (->rgb (hsv-combination (->hsv +blue+) (->hsv +green+) 0.5))
|
||||
#<RGB red: 1.0d0 green: 0.0d0 blue: 0.0d0>
|
||||
CL-COLORS> (->rgb (hsv-combination (->hsv +blue+) (->hsv +green+) 0.5 nil))
|
||||
#<RGB red: 0.0d0 green: 1.0d0 blue: 1.0d0>
|
||||
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; -*-
|
||||
|
||||
(in-package #:common-lisp-user)
|
||||
|
||||
(defpackage #:cl-colors
|
||||
(:use #:alexandria
|
||||
#:common-lisp
|
||||
#:let-plus)
|
||||
(:export
|
||||
#:rgb #:rgb-red #:rgb-green #:rgb-blue #:gray #:&rgb
|
||||
#:hsv #:hsv-hue #:hsv-saturation #:hsv-value #:&hsv
|
||||
#:rgb-to-hsv #:hsv-to-rgb #:hex-to-rgb #:as-hsv #:as-rgb
|
||||
#:rgb-combination #:hsv-combination
|
||||
#:parse-hex-rgb #:print-hex-rgb
|
||||
|
||||
;; predefined color names
|
||||
~A))
|
||||
|
|
@ -0,0 +1,674 @@
|
|||
;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; -*-
|
||||
|
||||
(in-package #:common-lisp-user)
|
||||
|
||||
(defpackage #:cl-colors
|
||||
(:use #:alexandria
|
||||
#:common-lisp
|
||||
#:let-plus)
|
||||
(:export
|
||||
#:rgb #:rgb-red #:rgb-green #:rgb-blue #:gray #:&rgb
|
||||
#:hsv #:hsv-hue #:hsv-saturation #:hsv-value #:&hsv
|
||||
#:rgb-to-hsv #:hsv-to-rgb #:hex-to-rgb #:as-hsv #:as-rgb
|
||||
#:rgb-combination #:hsv-combination
|
||||
#:parse-hex-rgb #:print-hex-rgb
|
||||
|
||||
;; predefined color names
|
||||
#:+snow+
|
||||
#:+ghostwhite+
|
||||
#:+whitesmoke+
|
||||
#:+gainsboro+
|
||||
#:+floralwhite+
|
||||
#:+oldlace+
|
||||
#:+linen+
|
||||
#:+antiquewhite+
|
||||
#:+papayawhip+
|
||||
#:+blanchedalmond+
|
||||
#:+bisque+
|
||||
#:+peachpuff+
|
||||
#:+navajowhite+
|
||||
#:+moccasin+
|
||||
#:+cornsilk+
|
||||
#:+ivory+
|
||||
#:+lemonchiffon+
|
||||
#:+seashell+
|
||||
#:+honeydew+
|
||||
#:+mintcream+
|
||||
#:+azure+
|
||||
#:+aliceblue+
|
||||
#:+lavender+
|
||||
#:+lavenderblush+
|
||||
#:+mistyrose+
|
||||
#:+white+
|
||||
#:+black+
|
||||
#:+darkslategray+
|
||||
#:+darkslategrey+
|
||||
#:+dimgray+
|
||||
#:+dimgrey+
|
||||
#:+slategray+
|
||||
#:+slategrey+
|
||||
#:+lightslategray+
|
||||
#:+lightslategrey+
|
||||
#:+gray+
|
||||
#:+grey+
|
||||
#:+lightgrey+
|
||||
#:+lightgray+
|
||||
#:+midnightblue+
|
||||
#:+navy+
|
||||
#:+navyblue+
|
||||
#:+cornflowerblue+
|
||||
#:+darkslateblue+
|
||||
#:+slateblue+
|
||||
#:+mediumslateblue+
|
||||
#:+lightslateblue+
|
||||
#:+mediumblue+
|
||||
#:+royalblue+
|
||||
#:+blue+
|
||||
#:+dodgerblue+
|
||||
#:+deepskyblue+
|
||||
#:+skyblue+
|
||||
#:+lightskyblue+
|
||||
#:+steelblue+
|
||||
#:+lightsteelblue+
|
||||
#:+lightblue+
|
||||
#:+powderblue+
|
||||
#:+paleturquoise+
|
||||
#:+darkturquoise+
|
||||
#:+mediumturquoise+
|
||||
#:+turquoise+
|
||||
#:+cyan+
|
||||
#:+lightcyan+
|
||||
#:+cadetblue+
|
||||
#:+mediumaquamarine+
|
||||
#:+aquamarine+
|
||||
#:+darkgreen+
|
||||
#:+darkolivegreen+
|
||||
#:+darkseagreen+
|
||||
#:+seagreen+
|
||||
#:+mediumseagreen+
|
||||
#:+lightseagreen+
|
||||
#:+palegreen+
|
||||
#:+springgreen+
|
||||
#:+lawngreen+
|
||||
#:+green+
|
||||
#:+chartreuse+
|
||||
#:+mediumspringgreen+
|
||||
#:+greenyellow+
|
||||
#:+limegreen+
|
||||
#:+yellowgreen+
|
||||
#:+forestgreen+
|
||||
#:+olivedrab+
|
||||
#:+darkkhaki+
|
||||
#:+khaki+
|
||||
#:+palegoldenrod+
|
||||
#:+lightgoldenrodyellow+
|
||||
#:+lightyellow+
|
||||
#:+yellow+
|
||||
#:+gold+
|
||||
#:+lightgoldenrod+
|
||||
#:+goldenrod+
|
||||
#:+darkgoldenrod+
|
||||
#:+rosybrown+
|
||||
#:+indianred+
|
||||
#:+saddlebrown+
|
||||
#:+sienna+
|
||||
#:+peru+
|
||||
#:+burlywood+
|
||||
#:+beige+
|
||||
#:+wheat+
|
||||
#:+sandybrown+
|
||||
#:+tan+
|
||||
#:+chocolate+
|
||||
#:+firebrick+
|
||||
#:+brown+
|
||||
#:+darksalmon+
|
||||
#:+salmon+
|
||||
#:+lightsalmon+
|
||||
#:+orange+
|
||||
#:+darkorange+
|
||||
#:+coral+
|
||||
#:+lightcoral+
|
||||
#:+tomato+
|
||||
#:+orangered+
|
||||
#:+red+
|
||||
#:+hotpink+
|
||||
#:+deeppink+
|
||||
#:+pink+
|
||||
#:+lightpink+
|
||||
#:+palevioletred+
|
||||
#:+maroon+
|
||||
#:+mediumvioletred+
|
||||
#:+violetred+
|
||||
#:+magenta+
|
||||
#:+violet+
|
||||
#:+plum+
|
||||
#:+orchid+
|
||||
#:+mediumorchid+
|
||||
#:+darkorchid+
|
||||
#:+darkviolet+
|
||||
#:+blueviolet+
|
||||
#:+purple+
|
||||
#:+mediumpurple+
|
||||
#:+thistle+
|
||||
#:+snow1+
|
||||
#:+snow2+
|
||||
#:+snow3+
|
||||
#:+snow4+
|
||||
#:+seashell1+
|
||||
#:+seashell2+
|
||||
#:+seashell3+
|
||||
#:+seashell4+
|
||||
#:+antiquewhite1+
|
||||
#:+antiquewhite2+
|
||||
#:+antiquewhite3+
|
||||
#:+antiquewhite4+
|
||||
#:+bisque1+
|
||||
#:+bisque2+
|
||||
#:+bisque3+
|
||||
#:+bisque4+
|
||||
#:+peachpuff1+
|
||||
#:+peachpuff2+
|
||||
#:+peachpuff3+
|
||||
#:+peachpuff4+
|
||||
#:+navajowhite1+
|
||||
#:+navajowhite2+
|
||||
#:+navajowhite3+
|
||||
#:+navajowhite4+
|
||||
#:+lemonchiffon1+
|
||||
#:+lemonchiffon2+
|
||||
#:+lemonchiffon3+
|
||||
#:+lemonchiffon4+
|
||||
#:+cornsilk1+
|
||||
#:+cornsilk2+
|
||||
#:+cornsilk3+
|
||||
#:+cornsilk4+
|
||||
#:+ivory1+
|
||||
#:+ivory2+
|
||||
#:+ivory3+
|
||||
#:+ivory4+
|
||||
#:+honeydew1+
|
||||
#:+honeydew2+
|
||||
#:+honeydew3+
|
||||
#:+honeydew4+
|
||||
#:+lavenderblush1+
|
||||
#:+lavenderblush2+
|
||||
#:+lavenderblush3+
|
||||
#:+lavenderblush4+
|
||||
#:+mistyrose1+
|
||||
#:+mistyrose2+
|
||||
#:+mistyrose3+
|
||||
#:+mistyrose4+
|
||||
#:+azure1+
|
||||
#:+azure2+
|
||||
#:+azure3+
|
||||
#:+azure4+
|
||||
#:+slateblue1+
|
||||
#:+slateblue2+
|
||||
#:+slateblue3+
|
||||
#:+slateblue4+
|
||||
#:+royalblue1+
|
||||
#:+royalblue2+
|
||||
#:+royalblue3+
|
||||
#:+royalblue4+
|
||||
#:+blue1+
|
||||
#:+blue2+
|
||||
#:+blue3+
|
||||
#:+blue4+
|
||||
#:+dodgerblue1+
|
||||
#:+dodgerblue2+
|
||||
#:+dodgerblue3+
|
||||
#:+dodgerblue4+
|
||||
#:+steelblue1+
|
||||
#:+steelblue2+
|
||||
#:+steelblue3+
|
||||
#:+steelblue4+
|
||||
#:+deepskyblue1+
|
||||
#:+deepskyblue2+
|
||||
#:+deepskyblue3+
|
||||
#:+deepskyblue4+
|
||||
#:+skyblue1+
|
||||
#:+skyblue2+
|
||||
#:+skyblue3+
|
||||
#:+skyblue4+
|
||||
#:+lightskyblue1+
|
||||
#:+lightskyblue2+
|
||||
#:+lightskyblue3+
|
||||
#:+lightskyblue4+
|
||||
#:+slategray1+
|
||||
#:+slategray2+
|
||||
#:+slategray3+
|
||||
#:+slategray4+
|
||||
#:+lightsteelblue1+
|
||||
#:+lightsteelblue2+
|
||||
#:+lightsteelblue3+
|
||||
#:+lightsteelblue4+
|
||||
#:+lightblue1+
|
||||
#:+lightblue2+
|
||||
#:+lightblue3+
|
||||
#:+lightblue4+
|
||||
#:+lightcyan1+
|
||||
#:+lightcyan2+
|
||||
#:+lightcyan3+
|
||||
#:+lightcyan4+
|
||||
#:+paleturquoise1+
|
||||
#:+paleturquoise2+
|
||||
#:+paleturquoise3+
|
||||
#:+paleturquoise4+
|
||||
#:+cadetblue1+
|
||||
#:+cadetblue2+
|
||||
#:+cadetblue3+
|
||||
#:+cadetblue4+
|
||||
#:+turquoise1+
|
||||
#:+turquoise2+
|
||||
#:+turquoise3+
|
||||
#:+turquoise4+
|
||||
#:+cyan1+
|
||||
#:+cyan2+
|
||||
#:+cyan3+
|
||||
#:+cyan4+
|
||||
#:+darkslategray1+
|
||||
#:+darkslategray2+
|
||||
#:+darkslategray3+
|
||||
#:+darkslategray4+
|
||||
#:+aquamarine1+
|
||||
#:+aquamarine2+
|
||||
#:+aquamarine3+
|
||||
#:+aquamarine4+
|
||||
#:+darkseagreen1+
|
||||
#:+darkseagreen2+
|
||||
#:+darkseagreen3+
|
||||
#:+darkseagreen4+
|
||||
#:+seagreen1+
|
||||
#:+seagreen2+
|
||||
#:+seagreen3+
|
||||
#:+seagreen4+
|
||||
#:+palegreen1+
|
||||
#:+palegreen2+
|
||||
#:+palegreen3+
|
||||
#:+palegreen4+
|
||||
#:+springgreen1+
|
||||
#:+springgreen2+
|
||||
#:+springgreen3+
|
||||
#:+springgreen4+
|
||||
#:+green1+
|
||||
#:+green2+
|
||||
#:+green3+
|
||||
#:+green4+
|
||||
#:+chartreuse1+
|
||||
#:+chartreuse2+
|
||||
#:+chartreuse3+
|
||||
#:+chartreuse4+
|
||||
#:+olivedrab1+
|
||||
#:+olivedrab2+
|
||||
#:+olivedrab3+
|
||||
#:+olivedrab4+
|
||||
#:+darkolivegreen1+
|
||||
#:+darkolivegreen2+
|
||||
#:+darkolivegreen3+
|
||||
#:+darkolivegreen4+
|
||||
#:+khaki1+
|
||||
#:+khaki2+
|
||||
#:+khaki3+
|
||||
#:+khaki4+
|
||||
#:+lightgoldenrod1+
|
||||
#:+lightgoldenrod2+
|
||||
#:+lightgoldenrod3+
|
||||
#:+lightgoldenrod4+
|
||||
#:+lightyellow1+
|
||||
#:+lightyellow2+
|
||||
#:+lightyellow3+
|
||||
#:+lightyellow4+
|
||||
#:+yellow1+
|
||||
#:+yellow2+
|
||||
#:+yellow3+
|
||||
#:+yellow4+
|
||||
#:+gold1+
|
||||
#:+gold2+
|
||||
#:+gold3+
|
||||
#:+gold4+
|
||||
#:+goldenrod1+
|
||||
#:+goldenrod2+
|
||||
#:+goldenrod3+
|
||||
#:+goldenrod4+
|
||||
#:+darkgoldenrod1+
|
||||
#:+darkgoldenrod2+
|
||||
#:+darkgoldenrod3+
|
||||
#:+darkgoldenrod4+
|
||||
#:+rosybrown1+
|
||||
#:+rosybrown2+
|
||||
#:+rosybrown3+
|
||||
#:+rosybrown4+
|
||||
#:+indianred1+
|
||||
#:+indianred2+
|
||||
#:+indianred3+
|
||||
#:+indianred4+
|
||||
#:+sienna1+
|
||||
#:+sienna2+
|
||||
#:+sienna3+
|
||||
#:+sienna4+
|
||||
#:+burlywood1+
|
||||
#:+burlywood2+
|
||||
#:+burlywood3+
|
||||
#:+burlywood4+
|
||||
#:+wheat1+
|
||||
#:+wheat2+
|
||||
#:+wheat3+
|
||||
#:+wheat4+
|
||||
#:+tan1+
|
||||
#:+tan2+
|
||||
#:+tan3+
|
||||
#:+tan4+
|
||||
#:+chocolate1+
|
||||
#:+chocolate2+
|
||||
#:+chocolate3+
|
||||
#:+chocolate4+
|
||||
#:+firebrick1+
|
||||
#:+firebrick2+
|
||||
#:+firebrick3+
|
||||
#:+firebrick4+
|
||||
#:+brown1+
|
||||
#:+brown2+
|
||||
#:+brown3+
|
||||
#:+brown4+
|
||||
#:+salmon1+
|
||||
#:+salmon2+
|
||||
#:+salmon3+
|
||||
#:+salmon4+
|
||||
#:+lightsalmon1+
|
||||
#:+lightsalmon2+
|
||||
#:+lightsalmon3+
|
||||
#:+lightsalmon4+
|
||||
#:+orange1+
|
||||
#:+orange2+
|
||||
#:+orange3+
|
||||
#:+orange4+
|
||||
#:+darkorange1+
|
||||
#:+darkorange2+
|
||||
#:+darkorange3+
|
||||
#:+darkorange4+
|
||||
#:+coral1+
|
||||
#:+coral2+
|
||||
#:+coral3+
|
||||
#:+coral4+
|
||||
#:+tomato1+
|
||||
#:+tomato2+
|
||||
#:+tomato3+
|
||||
#:+tomato4+
|
||||
#:+orangered1+
|
||||
#:+orangered2+
|
||||
#:+orangered3+
|
||||
#:+orangered4+
|
||||
#:+red1+
|
||||
#:+red2+
|
||||
#:+red3+
|
||||
#:+red4+
|
||||
#:+debianred+
|
||||
#:+deeppink1+
|
||||
#:+deeppink2+
|
||||
#:+deeppink3+
|
||||
#:+deeppink4+
|
||||
#:+hotpink1+
|
||||
#:+hotpink2+
|
||||
#:+hotpink3+
|
||||
#:+hotpink4+
|
||||
#:+pink1+
|
||||
#:+pink2+
|
||||
#:+pink3+
|
||||
#:+pink4+
|
||||
#:+lightpink1+
|
||||
#:+lightpink2+
|
||||
#:+lightpink3+
|
||||
#:+lightpink4+
|
||||
#:+palevioletred1+
|
||||
#:+palevioletred2+
|
||||
#:+palevioletred3+
|
||||
#:+palevioletred4+
|
||||
#:+maroon1+
|
||||
#:+maroon2+
|
||||
#:+maroon3+
|
||||
#:+maroon4+
|
||||
#:+violetred1+
|
||||
#:+violetred2+
|
||||
#:+violetred3+
|
||||
#:+violetred4+
|
||||
#:+magenta1+
|
||||
#:+magenta2+
|
||||
#:+magenta3+
|
||||
#:+magenta4+
|
||||
#:+orchid1+
|
||||
#:+orchid2+
|
||||
#:+orchid3+
|
||||
#:+orchid4+
|
||||
#:+plum1+
|
||||
#:+plum2+
|
||||
#:+plum3+
|
||||
#:+plum4+
|
||||
#:+mediumorchid1+
|
||||
#:+mediumorchid2+
|
||||
#:+mediumorchid3+
|
||||
#:+mediumorchid4+
|
||||
#:+darkorchid1+
|
||||
#:+darkorchid2+
|
||||
#:+darkorchid3+
|
||||
#:+darkorchid4+
|
||||
#:+purple1+
|
||||
#:+purple2+
|
||||
#:+purple3+
|
||||
#:+purple4+
|
||||
#:+mediumpurple1+
|
||||
#:+mediumpurple2+
|
||||
#:+mediumpurple3+
|
||||
#:+mediumpurple4+
|
||||
#:+thistle1+
|
||||
#:+thistle2+
|
||||
#:+thistle3+
|
||||
#:+thistle4+
|
||||
#:+gray0+
|
||||
#:+grey0+
|
||||
#:+gray1+
|
||||
#:+grey1+
|
||||
#:+gray2+
|
||||
#:+grey2+
|
||||
#:+gray3+
|
||||
#:+grey3+
|
||||
#:+gray4+
|
||||
#:+grey4+
|
||||
#:+gray5+
|
||||
#:+grey5+
|
||||
#:+gray6+
|
||||
#:+grey6+
|
||||
#:+gray7+
|
||||
#:+grey7+
|
||||
#:+gray8+
|
||||
#:+grey8+
|
||||
#:+gray9+
|
||||
#:+grey9+
|
||||
#:+gray10+
|
||||
#:+grey10+
|
||||
#:+gray11+
|
||||
#:+grey11+
|
||||
#:+gray12+
|
||||
#:+grey12+
|
||||
#:+gray13+
|
||||
#:+grey13+
|
||||
#:+gray14+
|
||||
#:+grey14+
|
||||
#:+gray15+
|
||||
#:+grey15+
|
||||
#:+gray16+
|
||||
#:+grey16+
|
||||
#:+gray17+
|
||||
#:+grey17+
|
||||
#:+gray18+
|
||||
#:+grey18+
|
||||
#:+gray19+
|
||||
#:+grey19+
|
||||
#:+gray20+
|
||||
#:+grey20+
|
||||
#:+gray21+
|
||||
#:+grey21+
|
||||
#:+gray22+
|
||||
#:+grey22+
|
||||
#:+gray23+
|
||||
#:+grey23+
|
||||
#:+gray24+
|
||||
#:+grey24+
|
||||
#:+gray25+
|
||||
#:+grey25+
|
||||
#:+gray26+
|
||||
#:+grey26+
|
||||
#:+gray27+
|
||||
#:+grey27+
|
||||
#:+gray28+
|
||||
#:+grey28+
|
||||
#:+gray29+
|
||||
#:+grey29+
|
||||
#:+gray30+
|
||||
#:+grey30+
|
||||
#:+gray31+
|
||||
#:+grey31+
|
||||
#:+gray32+
|
||||
#:+grey32+
|
||||
#:+gray33+
|
||||
#:+grey33+
|
||||
#:+gray34+
|
||||
#:+grey34+
|
||||
#:+gray35+
|
||||
#:+grey35+
|
||||
#:+gray36+
|
||||
#:+grey36+
|
||||
#:+gray37+
|
||||
#:+grey37+
|
||||
#:+gray38+
|
||||
#:+grey38+
|
||||
#:+gray39+
|
||||
#:+grey39+
|
||||
#:+gray40+
|
||||
#:+grey40+
|
||||
#:+gray41+
|
||||
#:+grey41+
|
||||
#:+gray42+
|
||||
#:+grey42+
|
||||
#:+gray43+
|
||||
#:+grey43+
|
||||
#:+gray44+
|
||||
#:+grey44+
|
||||
#:+gray45+
|
||||
#:+grey45+
|
||||
#:+gray46+
|
||||
#:+grey46+
|
||||
#:+gray47+
|
||||
#:+grey47+
|
||||
#:+gray48+
|
||||
#:+grey48+
|
||||
#:+gray49+
|
||||
#:+grey49+
|
||||
#:+gray50+
|
||||
#:+grey50+
|
||||
#:+gray51+
|
||||
#:+grey51+
|
||||
#:+gray52+
|
||||
#:+grey52+
|
||||
#:+gray53+
|
||||
#:+grey53+
|
||||
#:+gray54+
|
||||
#:+grey54+
|
||||
#:+gray55+
|
||||
#:+grey55+
|
||||
#:+gray56+
|
||||
#:+grey56+
|
||||
#:+gray57+
|
||||
#:+grey57+
|
||||
#:+gray58+
|
||||
#:+grey58+
|
||||
#:+gray59+
|
||||
#:+grey59+
|
||||
#:+gray60+
|
||||
#:+grey60+
|
||||
#:+gray61+
|
||||
#:+grey61+
|
||||
#:+gray62+
|
||||
#:+grey62+
|
||||
#:+gray63+
|
||||
#:+grey63+
|
||||
#:+gray64+
|
||||
#:+grey64+
|
||||
#:+gray65+
|
||||
#:+grey65+
|
||||
#:+gray66+
|
||||
#:+grey66+
|
||||
#:+gray67+
|
||||
#:+grey67+
|
||||
#:+gray68+
|
||||
#:+grey68+
|
||||
#:+gray69+
|
||||
#:+grey69+
|
||||
#:+gray70+
|
||||
#:+grey70+
|
||||
#:+gray71+
|
||||
#:+grey71+
|
||||
#:+gray72+
|
||||
#:+grey72+
|
||||
#:+gray73+
|
||||
#:+grey73+
|
||||
#:+gray74+
|
||||
#:+grey74+
|
||||
#:+gray75+
|
||||
#:+grey75+
|
||||
#:+gray76+
|
||||
#:+grey76+
|
||||
#:+gray77+
|
||||
#:+grey77+
|
||||
#:+gray78+
|
||||
#:+grey78+
|
||||
#:+gray79+
|
||||
#:+grey79+
|
||||
#:+gray80+
|
||||
#:+grey80+
|
||||
#:+gray81+
|
||||
#:+grey81+
|
||||
#:+gray82+
|
||||
#:+grey82+
|
||||
#:+gray83+
|
||||
#:+grey83+
|
||||
#:+gray84+
|
||||
#:+grey84+
|
||||
#:+gray85+
|
||||
#:+grey85+
|
||||
#:+gray86+
|
||||
#:+grey86+
|
||||
#:+gray87+
|
||||
#:+grey87+
|
||||
#:+gray88+
|
||||
#:+grey88+
|
||||
#:+gray89+
|
||||
#:+grey89+
|
||||
#:+gray90+
|
||||
#:+grey90+
|
||||
#:+gray91+
|
||||
#:+grey91+
|
||||
#:+gray92+
|
||||
#:+grey92+
|
||||
#:+gray93+
|
||||
#:+grey93+
|
||||
#:+gray94+
|
||||
#:+grey94+
|
||||
#:+gray95+
|
||||
#:+grey95+
|
||||
#:+gray96+
|
||||
#:+grey96+
|
||||
#:+gray97+
|
||||
#:+grey97+
|
||||
#:+gray98+
|
||||
#:+grey98+
|
||||
#:+gray99+
|
||||
#:+grey99+
|
||||
#:+gray100+
|
||||
#:+grey100+
|
||||
#:+darkgrey+
|
||||
#:+darkgray+
|
||||
#:+darkblue+
|
||||
#:+darkcyan+
|
||||
#:+darkmagenta+
|
||||
#:+darkred+
|
||||
#:+lightgreen+))
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
;;; parse X11's rgb.txt
|
||||
;;;
|
||||
;;; no packages defined as this should just be run as a script.
|
||||
|
||||
(require :cl-ppcre)
|
||||
(require :alexandria)
|
||||
|
||||
(defun write-package-file (colornames
|
||||
&key (package-template-path "package-template.lisp")
|
||||
(package-file-path "package.lisp"))
|
||||
"Write a package definition file, exporting COLORNAMES, using the given template."
|
||||
(let* ((package-template (alexandria:read-file-into-string package-template-path))
|
||||
(colornames-export
|
||||
(reduce (lambda (a b) (format nil "~A~%~A" a b))
|
||||
colornames
|
||||
:key (lambda (colorname)
|
||||
(format nil " #:+~A+" colorname)))))
|
||||
(with-open-file (package-file package-file-path
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
:if-does-not-exist :create)
|
||||
(format package-file package-template colornames-export))
|
||||
(values)))
|
||||
|
||||
(defun parse-and-write-color-definitions (&key
|
||||
(source-path "/usr/share/X11/rgb.txt")
|
||||
(destination-path "colornames.lisp"))
|
||||
"Parse color definitions and write them into a file. Return the list of colors (for exporting)."
|
||||
(let ((color-scanner ; will only take names w/o spaces
|
||||
(cl-ppcre:create-scanner
|
||||
"^\\s*(\\d+)\\s+(\\d+)\\s+(\\d+)\\s+([\\s\\w]+\?)\\s*$"
|
||||
:extended-mode t))
|
||||
(comment-scanner (cl-ppcre:create-scanner "^\\s*!"))
|
||||
colornames)
|
||||
(with-open-file (source source-path
|
||||
:direction :input
|
||||
:if-does-not-exist :error)
|
||||
(with-open-file (colordefs destination-path
|
||||
:direction :output
|
||||
:if-exists :supersede
|
||||
:if-does-not-exist :create)
|
||||
(format colordefs ";;;; This file was generated automatically ~
|
||||
by parse-x11.lisp~%~
|
||||
;;;; Please do not edit directly, just run make if necessary (but should not be).~2%~
|
||||
(in-package #:cl-colors)~2%")
|
||||
(labels ((parse-channel (string)
|
||||
(let ((i (read-from-string string)))
|
||||
(assert (and (typep i 'integer) (<= i 255)))
|
||||
(/ i 255))))
|
||||
(do ((line (read-line source nil nil) (read-line source nil nil)))
|
||||
((not line))
|
||||
(unless (cl-ppcre:scan-to-strings comment-scanner line)
|
||||
(multiple-value-bind (match registers)
|
||||
(cl-ppcre:scan-to-strings color-scanner line)
|
||||
(if (and match (not (find #\space (aref registers 3))))
|
||||
(let ((colorname (string-downcase (aref registers 3))))
|
||||
(format colordefs
|
||||
"(define-rgb-color ~A ~A ~A ~A)~%"
|
||||
colorname
|
||||
(parse-channel (aref registers 0))
|
||||
(parse-channel (aref registers 1))
|
||||
(parse-channel (aref registers 2)))
|
||||
(push colorname colornames))
|
||||
(format t "ignoring line ~A~%" line)))))))
|
||||
(nreverse colornames))))
|
||||
|
||||
(let ((colornames (parse-and-write-color-definitions)))
|
||||
(write-package-file colornames))
|
||||
|
|
@ -0,0 +1,82 @@
|
|||
(in-package #:cl-user)
|
||||
|
||||
(defpackage #:cl-colors-tests
|
||||
(:use #:alexandria #:common-lisp #:cl-colors #:let-plus #:lift)
|
||||
(:export #:run))
|
||||
|
||||
(in-package #:cl-colors-tests)
|
||||
|
||||
(deftestsuite cl-colors-tests () ())
|
||||
|
||||
(defun run ()
|
||||
"Run all the tests for CL-COLORS-TESTS."
|
||||
(run-tests :suite 'cl-colors-tests))
|
||||
|
||||
(defun eps= (a b &optional (epsilon 1e-10))
|
||||
(<= (abs (- a b)) epsilon))
|
||||
|
||||
(defun rgb= (rgb1 rgb2 &optional (epsilon 1e-10))
|
||||
"Compare RGB colors for (numerical) equality."
|
||||
(let+ (((&rgb red1 green1 blue1) rgb1)
|
||||
((&rgb red2 green2 blue2) rgb2))
|
||||
(and (eps= red1 red2 epsilon)
|
||||
(eps= green1 green2 epsilon)
|
||||
(eps= blue1 blue2 epsilon))))
|
||||
|
||||
(defun random-rgb ()
|
||||
(rgb (random 1d0) (random 1d0) (random 1d0)))
|
||||
|
||||
(addtest (cl-colors-tests)
|
||||
rgb<->hsv
|
||||
(loop repeat 100 do
|
||||
(let ((rgb (random-rgb)))
|
||||
(ensure-same rgb (as-rgb (as-hsv rgb)) :test #'rgb=))))
|
||||
|
||||
;; (defun test-hue-combination (from to positivep)
|
||||
;; (dotimes (i 21)
|
||||
;; (format t "~a " (hue-combination from to (/ i 20) positivep))))
|
||||
|
||||
(addtest (cl-colors-tests)
|
||||
print-hex-rgb
|
||||
(let ((rgb (rgb 0.070 0.203 0.337)))
|
||||
(ensure-same "#123456" (print-hex-rgb rgb))
|
||||
(ensure-same "123456" (print-hex-rgb rgb :hash nil))
|
||||
(ensure-same "#135" (print-hex-rgb rgb :short t))
|
||||
(ensure-same "135" (print-hex-rgb rgb :hash nil :short t))
|
||||
(ensure-same "#12345678" (print-hex-rgb rgb :alpha 0.47))
|
||||
(ensure-same "12345678" (print-hex-rgb rgb :alpha 0.47 :hash nil))
|
||||
(ensure-same "#1357" (print-hex-rgb rgb :alpha 0.47 :short t))
|
||||
(ensure-same "1357" (print-hex-rgb rgb :alpha 0.47 :hash nil :short t))))
|
||||
|
||||
(addtest (cl-colors-tests)
|
||||
parse-hex-rgb
|
||||
(let ((rgb (rgb 0.070 0.203 0.337)))
|
||||
(ensure-same rgb (parse-hex-rgb "#123456") :test (rcurry #'rgb= 0.01))
|
||||
(ensure-same rgb (parse-hex-rgb "123456") :test (rcurry #'rgb= 0.01))
|
||||
(ensure-same rgb (parse-hex-rgb "#135") :test (rcurry #'rgb= 0.01))
|
||||
(ensure-same rgb (parse-hex-rgb "135") :test (rcurry #'rgb= 0.01))
|
||||
|
||||
(flet ((aux (list1 list2)
|
||||
(and (rgb= (car list1) (car list2) 0.01)
|
||||
(eps= (cadr list1) (cadr list2) 0.01))))
|
||||
(ensure-same (list rgb 0.47) (multiple-value-list (parse-hex-rgb "#12345678")) :test #'aux)
|
||||
(ensure-same (list rgb 0.47) (multiple-value-list (parse-hex-rgb "12345678")) :test #'aux)
|
||||
(ensure-same (list rgb 0.47) (multiple-value-list (parse-hex-rgb "#1357")) :test #'aux)
|
||||
(ensure-same (list rgb 0.47) (multiple-value-list (parse-hex-rgb "1357")) :test #'aux))))
|
||||
|
||||
(addtest (cl-colors-tests)
|
||||
print-hex-rgb/format
|
||||
(ensure-same "#123456" (with-output-to-string (*standard-output*)
|
||||
(print-hex-rgb (rgb 0.070 0.203 0.337)
|
||||
:destination T))))
|
||||
|
||||
(addtest (cl-colors-tests)
|
||||
hex<->rgb
|
||||
(loop repeat 100 do
|
||||
(let ((rgb (random-rgb)))
|
||||
(ensure-same rgb (parse-hex-rgb (print-hex-rgb rgb)) :test (rcurry #'rgb= 0.01)))))
|
||||
|
||||
(addtest (cl-colors-tests)
|
||||
parse-hex-rgb-ranges
|
||||
(ensure-same (rgb 0.070 0.203 0.337) (parse-hex-rgb "foo#123456zzz" :start 3 :end 10)
|
||||
:test (rcurry #'rgb= 0.001)))
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
CL-EMB has fixes by current maintainer, Michael Raskin <38a938c2@rambler.ru>
|
||||
This fixes are Copyright (c) 2009 by Moscow Center of Continious
|
||||
Mathematical Education.
|
||||
|
||||
CL-EMB is written and Copyright (c) 2004, 2005, 2006 by Stefan Scholl.
|
||||
Parts of the source are taken from LSP, written by
|
||||
John Wiseman and copyright 2001, 2002 I/NET Inc.
|
||||
See lsp-LICENSE.txt
|
||||
|
||||
CL-EMB is licensed under the terms of the Lisp Lesser GNU
|
||||
Public License (http://opensource.franz.com/preamble.html), known as
|
||||
the LLGPL. The LLGPL consists of a preamble (see above URL) and the
|
||||
LGPL. Where these conflict, the preamble takes precedence.
|
||||
CL-EMB is referenced in the preamble as the "LIBRARY."
|
||||
|
|
@ -0,0 +1,339 @@
|
|||
# cl-emb: Embedded Common Lisp
|
||||
|
||||
A mixture of features from eRuby and HTML::Template. You could name it "Yet
|
||||
Another LSP" (LispServer Pages) but it's a bit more than that and not limited to
|
||||
a certain server or text format.
|
||||
|
||||
This is a mirror of http://mtn-host.prjek.net/projects/cl-emb
|
||||
|
||||
The primary development repository is in Monotone, this repository will receive
|
||||
just the automated snapshots.
|
||||
|
||||
# License
|
||||
|
||||
[LLGPL](http://opensource.franz.com/preamble.html)
|
||||
|
||||
# Installing
|
||||
|
||||
```lisp
|
||||
(ql:quickload :cl-emb)
|
||||
```
|
||||
|
||||
CL-EMB can also be installed manually with [ASDF-INSTALL](http://weitz.de/asdf-install/).
|
||||
|
||||
# Usage
|
||||
|
||||
## [generic function] `EXECUTE-EMB name &key env generator-maker => string`
|
||||
|
||||
`NAME` can be a registered (with `REGISTER-EMB`) emb code or a pathname (type
|
||||
`PATHNAME`) of a file containing the code. Returns a string. Keyword parameter
|
||||
ENV to pass objects to the code. `ENV` must be a plist. `ENV` can be accessed
|
||||
within your emb code. The `GENERATOR-MAKER` is a function which gets called
|
||||
with a key and value from the given `ENV` and should return a generator function
|
||||
like described
|
||||
[here](http://www.cs.northwestern.edu/academics/courses/325/readings/graham/generators.html).
|
||||
|
||||
|
||||
## [generic function] `REGISTER-EMB name code => emb-function`
|
||||
|
||||
Internally registeres given `CODE` with `NAME` to be called with
|
||||
`EXECUTE-EMB`. `CODE` can be a string or a pathname (type `PATHNAME`) of a file
|
||||
containing the code.
|
||||
|
||||
## [function] `PPRINT-EMB-FUNCTION name`
|
||||
|
||||
`DEBUG` function. Pretty prints function form, if `*DEBUG*` was `T` when the
|
||||
function was registered.
|
||||
|
||||
## [function] `CLEAR-EMB name`
|
||||
|
||||
Remove named emb code.
|
||||
|
||||
## [function] `CLEAR-EMB-ALL`
|
||||
|
||||
Remove all registered emb code.
|
||||
|
||||
## [function] `CLEAR-EMB-ALL-FILES`
|
||||
|
||||
Remove all registered file emb code (registered/executed by a pathname).
|
||||
|
||||
## [special variable] `*EMB-START-MARKER*` (default `"<%"`)
|
||||
|
||||
Start of scriptlet or expression. Remember that a following `#\=` indicates an
|
||||
expression.
|
||||
|
||||
## [special variable] `*EMB-END-MARKER*` (default `"%>"`)
|
||||
|
||||
End of scriptlet or expression.
|
||||
|
||||
## [special variable] `*ESCAPE-TYPE*`
|
||||
|
||||
Default value for escaping `@var` output is `:RAW` Can be changed to `:XML`,
|
||||
`:HTML`, `:URI`, `:URL`, `:URL-ENCODE`, `:LATEX`.
|
||||
|
||||
## [special variable] `*FUNCTION-PACKAGE*`
|
||||
|
||||
Package the emb function body gets interned to.
|
||||
|
||||
Default: `(find-package :cl-emb-intern)`.
|
||||
|
||||
## [special variable] `*DEBUG*`
|
||||
|
||||
Debugging mode if `T`. Default: `NIL`.
|
||||
|
||||
## [special variable] `*LOCKING-FUNCTION*`
|
||||
|
||||
Function to call to lock access to an internal hash table. Must accept a
|
||||
function designator which must be called with the lock hold.
|
||||
|
||||
**IMPORTANT:** The locking function must return the value of the function it
|
||||
calls!
|
||||
|
||||
Example:
|
||||
|
||||
```lisp
|
||||
(defvar *emb-lock* (kmrcl::make-lock "emb-lock")
|
||||
"Lock for CL-EMB.")
|
||||
|
||||
(defun emb-lock-function (func)
|
||||
"Lock function for CL-EMB."
|
||||
(kmrcl::with-lock-held (*emb-lock*)
|
||||
(funcall func)))
|
||||
|
||||
(setf emb:*locking-function* 'emb-lock-function)
|
||||
```
|
||||
|
||||
Files get cached and reread when they change.
|
||||
|
||||
The emb code consists of normal text (HTML, XML, or any other text format) and
|
||||
special tags you know from eRuby or JSP (JavaServer Pages) which can hold Common
|
||||
Lisp or CL-EMB's template tags, perhaps comparable to JSP's taglib.
|
||||
|
||||
- `<% ... %>` is a scriptlet tag, and wraps Common Lisp code.
|
||||
- `<%= ... %>` is an expression tag. Its content gets evaluated and fed as a
|
||||
parameter to `(FORMAT T "~A" ...)`.
|
||||
- `<%# ... #%>` is a comment. Everything within will be removed/ignored. Can't
|
||||
be nested!
|
||||
|
||||
## Examples
|
||||
|
||||
```lisp
|
||||
CL-USER> (asdf:oos 'asdf:load-op :cl-emb)
|
||||
CL-USER> (cl-emb:register-emb "test1"
|
||||
"10 stars: <% (dotimes (i 10) %>*<% ) %>")
|
||||
#<CL-EMB::EMB-FUNCTION {9B74259}>
|
||||
CL-USER> (cl-emb:execute-emb "test1")
|
||||
"10 stars: **********"
|
||||
|
||||
CL-USER> (cl-emb:register-emb "test2" "2 + 2 = <%= (+ 2 2) %>")
|
||||
#<CL-EMB::EMB-FUNCTION {9BCACE1}>
|
||||
CL-USER> (cl-emb:execute-emb "test2")
|
||||
"2 + 2 = 4"
|
||||
|
||||
CL-USER> (let ((emb:*emb-start-marker* "<?emb")
|
||||
(emb:*emb-end-marker* "?>"))
|
||||
(emb:register-emb "marker-test"
|
||||
"42 + 42 = <?emb= (+ 42 42) ?>"))
|
||||
#<CL-EMB::EMB-FUNCTION {97BEFD9}>
|
||||
CL-USER> (emb:execute-emb "marker-test")
|
||||
"42 + 42 = 84"
|
||||
```
|
||||
|
||||
# Template Tags
|
||||
|
||||
You can use special template tags instead of Common Lisp code between `<%` and
|
||||
`%>`. This will be translated to Common Lisp and serves as a simple shortcut for
|
||||
you.
|
||||
|
||||
And more important: It's easier to use for non-programmers. A designer can work
|
||||
on HTML code and insert these simple template tags.
|
||||
|
||||
Template tags start with `@`.
|
||||
|
||||
Currently supported: `@if`, `@else`, `@endif`, `@ifnotempty`, `@unless`,
|
||||
`@endunless`, `@var`, `@repeat`, `@endrepeat`, `@loop`, `@endloop`, `@include`,
|
||||
`@includevar`, `@call`, `@with`, `@endwith`, `@set`, `@genloop`, `@endgenloop`,
|
||||
`@insert`.
|
||||
|
||||
`@if` and `@unless` check if the given parameter is set in the supplied
|
||||
environment (parameter ENV of `EXECUTE-EMB`). The environment is a plist with
|
||||
keyword + value pairs. Must be terminated with `@endif` or `@endunless`.
|
||||
|
||||
`@ifnotempty` works like `@if` but considers the empty string false.
|
||||
|
||||
`@ifequal` accepts two parameters interpreted as variable names. It works like
|
||||
`@if` but checks whether the values of two variables are equal. Variable names
|
||||
are intepreted as in `@var`.
|
||||
|
||||
Note that `@ifnotempty` and `@ifequal` are supposed to be used together with
|
||||
`@else` and `@endif`.
|
||||
|
||||
`@var` emits the corresponding value from the environment. Uses the escape type
|
||||
defined in `*ESCAPE-TYPE*` (Default `:raw`, no escaping) or with -escape
|
||||
modifier. E.g. `<% @var foo -escape xml %>` or without modifier `<% @var foo
|
||||
%>` Supported escaping: `raw`, `xml` (aka `html`), `uri` (aka `url` or
|
||||
`url-encode`), `latex`.
|
||||
|
||||
`@insert` inserts a given (text) file. Parameter from the environment. E.g. `<%
|
||||
@insert textfile %>`.
|
||||
|
||||
`@repeat` repeats everything between it and `@endrepeat` the given
|
||||
times. Parameter can be a number or a name. The name will be used to lookup the
|
||||
corresponding value from the environment.
|
||||
|
||||
`@loop` loops over a named list in the environment. Environment gets set to
|
||||
current plist inside this list. Must be terminated with `@endloop`.
|
||||
|
||||
`@include` includes a given file. Relative to current template. `@includevar`
|
||||
does the same, but the parameter is treated like a variable name containing the
|
||||
path to the file. Variable name is treated like in `@var`.
|
||||
|
||||
`@call` calls a given emb-function, which was registered with `REGISTER-EMB`.
|
||||
|
||||
`@with` is similar to `@loop` as it sets the current environment to the named
|
||||
plist. `@loop` needs a list of plists and `@with` just a plist associated to the
|
||||
given name. Block ends in `@endwith`.
|
||||
|
||||
`@set` is used to set special variables like `*ESCAPE-TYPE*` from within a emb
|
||||
code. This way a default for a file can be specified in the file itself. The
|
||||
variables are changed for the current and called/included code. Changes to the
|
||||
variables in called/included code don't effect the caller/ includer. E.g. `<%
|
||||
@set escape=uri %>`. Currently supported: `escape` (`raw`, `xml`, `html`, `url`,
|
||||
`uri`, `url-encode`, `latex`).
|
||||
|
||||
`@genloop` starts a special kind of loop: a generator loop. It must be
|
||||
terminated by `@endgenloop` and operates on a generator returned by the given
|
||||
`GENERATOR-MAKER` (see `EXECUTE-EMB`). The `GENERATOR-MAKER` gets called with
|
||||
two parameters: the key (which is the argument to `@genloop`) and the
|
||||
corresponding value in the plist. Each time in the loop the generator is called
|
||||
first with the parameter `:TEST` to see if there's data left. The generator
|
||||
must return a plist on `:NEXT`, which will be the current `ENV` (like `@with` or
|
||||
within a normal `@loop`).
|
||||
|
||||
The parameters which access the environment can just be the name of a keyword
|
||||
symbol in the plist. `foo` -> :FOO in `(:FOO "bar")` Or you can provide a path
|
||||
within a nested plist structure by dividing the parts of the path with a
|
||||
slash. `foo/bar` -> Value of `:BAR` inside the plist at `:FOO`. `(:FOO (:BAR
|
||||
"yeah"))` -> `"yeah"` Starting the parameter with a slash lets it traverse the
|
||||
nested plists from the top. That way you can access top values inside loops.
|
||||
|
||||
Writing `<% @var foo/bar/quux %>` can be translated to `(GETF (GETF (GETF ENV
|
||||
:FOO) :BAR) :QUUX)`.
|
||||
|
||||
## Examples
|
||||
|
||||
```lisp
|
||||
CL-USER> (cl-emb:register-emb "test1"
|
||||
"Foo: <% @if foo %>Yes!<% @else %>No!<% @endif %>")
|
||||
#<CL-EMB::EMB-FUNCTION {9C0F2D1}>
|
||||
CL-USER> (cl-emb:execute-emb "test1" :env '(:foo t))
|
||||
"Foo: Yes!"
|
||||
CL-USER> (cl-emb:execute-emb "test1")
|
||||
"Foo: No!"
|
||||
CL-USER> (cl-emb:execute-emb "test1" :env '(:foo nil))
|
||||
"Foo: No!"
|
||||
|
||||
CL-USER> (cl-emb:register-emb "test2"
|
||||
"What is set? -> <% @call test1 %>")
|
||||
#<CL-EMB::EMB-FUNCTION {9C526E9}>
|
||||
CL-USER> (cl-emb:execute-emb "test2" :env '(:foo t))
|
||||
"What is set? -> Foo: Yes!"
|
||||
|
||||
CL-USER> (cl-emb:register-emb "test3"
|
||||
"10 stars: <% @repeat 10 %>*<% @endrepeat %>")
|
||||
#<CL-EMB::EMB-FUNCTION {9C9F1D1}>
|
||||
CL-USER> (cl-emb:execute-emb "test3")
|
||||
"10 stars: **********"
|
||||
|
||||
CL-USER> (cl-emb:register-emb "test4"
|
||||
"<% @loop numbers %>[<% @var de %>,<% @var en %>]<% @endloop %>")
|
||||
#<CL-EMB::EMB-FUNCTION {9174DF1}>
|
||||
CL-USER> (cl-emb:execute-emb "test4"
|
||||
:env '(:numbers ((:de "EINS" :en "ONE")
|
||||
(:de "ZWEI" :en "TWO"))))
|
||||
"[EINS,ONE][ZWEI,TWO]"
|
||||
|
||||
CL-USER> (emb:register-emb "test5"
|
||||
"<a href=\"http://somewhere.test/test.cgi?<% @var foo -escape uri %>\"><% @var foo %></a>")
|
||||
#<CL-EMB::EMB-FUNCTION {9FBF5F1}>
|
||||
CL-USER> (let ((emb:*escape-type* :html))
|
||||
(emb:execute-emb "test5" :env '(:foo "10 > 7")))
|
||||
"<a href=\"http://somewhere.test/test.cgi?10+%3E+7\">10 > 7</a>"
|
||||
|
||||
CL-USER> (emb:register-emb "test6" "1. <% @with one %>BAZ: <% @var baz %><% @endwith%>
|
||||
2. <% @with two %>BAZ: <% @var baz %><% @endwith%>")
|
||||
#<CL-EMB::EMB-FUNCTION {9916EB1}>
|
||||
CL-USER> (emb:execute-emb "test6" :env '(:one (:baz "first")
|
||||
:two (:baz "second")))
|
||||
"1. BAZ: first
|
||||
2. BAZ: second"
|
||||
|
||||
CL-USER> (emb:register-emb "test7" " - <% @var foo -escape uri %> - ")
|
||||
#<CL-EMB::EMB-FUNCTION {96F1239}>
|
||||
CL-USER> (emb:pprint-emb-function "test7")
|
||||
|
||||
(LAMBDA (&OPTIONAL CL-EMB-INTERN::ENV)
|
||||
(WITH-OUTPUT-TO-STRING (*STANDARD-OUTPUT*)
|
||||
(PROGN
|
||||
(WRITE-STRING " - ")
|
||||
(FORMAT T "~A" (CL-EMB::ECHO (GETF CL-EMB-INTERN::ENV :FOO) :ESCAPE :URI))
|
||||
(WRITE-STRING " - "))))
|
||||
; No value
|
||||
|
||||
CL-USER> (emb:register-emb "test8" "<% @set escape=xml %>--<% @var hey %>--")
|
||||
#<CL-EMB::EMB-FUNCTION {962B839}>
|
||||
CL-USER> (emb:register-emb "test9" "--<% @var hey %>--<% @call test8 %>--<% @var hey %>--")
|
||||
#<CL-EMB::EMB-FUNCTION {96931A9}>
|
||||
CL-USER> (emb:execute-emb "test9" :env '(:hey "5>2"))
|
||||
"--5>2----5>2----5>2--"
|
||||
|
||||
CL-USER> (emb:register-emb "test10" "Square root from 1 to <% @var numbers %>: <% @genloop numbers %>sqrt(<% @var number %>) = <% @var sqrt %> <% @endgenloop %>")
|
||||
#<CL-EMB::EMB-FUNCTION {581EC765}>
|
||||
CL-USER> (defun make-sqrt-1-to-n-gen (key n)
|
||||
(declare (ignore key))
|
||||
(let ((i 1))
|
||||
#'(lambda (cmd)
|
||||
(ecase cmd
|
||||
(:test (> i n))
|
||||
(:get `(:number ,i :sqrt ,(sqrt i)))
|
||||
(:next (prog1 `(:number ,i :sqrt ,(sqrt i))
|
||||
(unless (> i n)
|
||||
(incf i))))))))
|
||||
MAKE-SQRT-1-TO-N-GEN
|
||||
CL-USER> (emb:execute-emb "test10" :env '(:numbers 10) :generator-maker 'make-sqrt-1-to-n-gen)
|
||||
"Square root from 1 to 10: sqrt(1) = 1.0 sqrt(2) = 1.4142135 sqrt(3) = 1.7320508 sqrt(4) = 2.0 sqrt(5) = 2.236068 sqrt(6) = 2.4494898 sqrt(7) = 2.6457512 sqrt(8) = 2.828427 sqrt(9) = 3.0 sqrt(10) = 3.1622777 "
|
||||
|
||||
CL-USER> (emb:register-emb "test11" "<% @loop bands %>Band: <% @var band %> (Genre: <% @var /genre %>)<br><% @endloop %>")
|
||||
#<CL-EMB::EMB-FUNCTION {58ADB12D}>
|
||||
CL-USER> (emb:execute-emb "test11" :env '(:genre "Rock" :bands ((:band "Queen") (:band "The Rolling Stones") (:band "ZZ Top"))))
|
||||
"Band: Queen (Genre: Rock)<br>Band: The Rolling Stones (Genre: Rock)<br>Band: ZZ Top (Genre: Rock)<br>"
|
||||
|
||||
CL-USER> (emb:register-emb "test12" "<% @repeat /foo/bar/count %>*<% @endrepeat %>")
|
||||
#<CL-EMB::EMB-FUNCTION {58B7583D}>
|
||||
CL-USER> (emb:execute-emb "test12" :env '(:foo (:bar (:count 42))))
|
||||
"******************************************"
|
||||
|
||||
CL-USER> (emb:register-emb "test13" "The file:<pre><% @insert textfile %></pre>")
|
||||
#<CL-EMB::EMB-FUNCTION {5894326D}>
|
||||
CL-USER> (emb:execute-emb "test13" :env '(:textfile "/etc/gentoo-release"))
|
||||
"The file:<pre>Gentoo Base System version 1.6.14
|
||||
</pre>"
|
||||
```
|
||||
|
||||
# Credits
|
||||
|
||||
Uses code from John Wiseman. See http://lemonodor.com/archives/000128.html and
|
||||
lsp-LICENSE.txt Thanks to Edi Weitz for letting me use his code for
|
||||
`ESCAPE-FOR-XML`.
|
||||
|
||||
Thanks to Eitarow Fukamachi for the whitespace-trimming patch.
|
||||
|
||||
Thanks to Christoph Finkensiep for making `getf*` a generic function.
|
||||
|
||||
# Author
|
||||
|
||||
Stefan Scholl <stesch@no-spoon.de>
|
||||
|
||||
# Current Maintainer
|
||||
|
||||
Michael Raskin <38a938c2@rambler.ru>
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
|
||||
- Documentation
|
||||
|
||||
- More examples
|
||||
|
||||
- Tests
|
||||
|
||||
- Writing own escape functions?
|
||||
|
||||
- Better error handling
|
||||
|
||||
- Examples for generator loop in the examples.html
|
||||
|
||||
- Export GETF-EMB
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||
|
||||
;;; This software is Copyright (c) Stefan Scholl, 2004.
|
||||
;;; Stefan Scholl grants you the rights to distribute
|
||||
;;; and use this software as governed by the terms
|
||||
;;; of the Lisp Lesser GNU Public License
|
||||
;;; (http://opensource.franz.com/preamble.html),
|
||||
;;; known as the LLGPL.
|
||||
|
||||
|
||||
(in-package #:cl-user)
|
||||
|
||||
(defpackage #:cl-emb.system
|
||||
(:use #:cl
|
||||
#:asdf))
|
||||
|
||||
(in-package #:cl-emb.system)
|
||||
|
||||
(defsystem #:cl-emb
|
||||
:version "0.4.3"
|
||||
:author "Stefan Scholl <stesch@no-spoon.de>"
|
||||
:licence "Lesser Lisp General Public License"
|
||||
:description "A templating system for Common Lisp"
|
||||
:depends-on (#:cl-ppcre)
|
||||
:components ((:file "packages")
|
||||
(:file "emb" :depends-on ("packages"))))
|
||||
|
|
@ -0,0 +1,523 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||
|
||||
;;; This file contains some fixes by Michael Raskin
|
||||
;;; They are Copyright (c) Moscow Center of Continious Mathematical
|
||||
;;; Education, 2009
|
||||
|
||||
;;; This software is Copyright (c) Stefan Scholl, 2004.
|
||||
;;; Stefan Scholl grants you the rights to distribute
|
||||
;;; and use this software as governed by the terms
|
||||
;;; of the Lisp Lesser GNU Public License
|
||||
;;; (http://opensource.franz.com/preamble.html),
|
||||
;;; known as the LLGPL.
|
||||
|
||||
;;; Parts of the source are taken from LSP, written by
|
||||
;;; John Wiseman and copyright 2001, 2002 I/NET Inc.
|
||||
;;; (http://www.inetmi.com/)
|
||||
;;; See lsp-LICENSE.txt
|
||||
|
||||
|
||||
(in-package :cl-emb)
|
||||
|
||||
(defpackage :cl-emb-intern (:use :cl))
|
||||
|
||||
(defvar *function-package* (find-package :cl-emb-intern)
|
||||
"Package the emb function body gets interned to.")
|
||||
|
||||
(defvar *debug* nil
|
||||
"Debugging for CL-EMB.")
|
||||
|
||||
(defvar *locking-function* nil
|
||||
"Function to call to lock access to an internal hash table. Must accept
|
||||
a function designator which must be called with the lock hold.")
|
||||
|
||||
|
||||
(defmacro with-lock (&body body)
|
||||
"Locking all accesses to *functions*"
|
||||
`(cond (*locking-function*
|
||||
(funcall *locking-function* #'(lambda () ,@body)))
|
||||
(t ,@body)))
|
||||
|
||||
(defgeneric execute-emb (name &key env generator-maker)
|
||||
(:documentation "Execute named emb code. Returns a string. Keyword parameter ENV
|
||||
to pass objects to the code. ENV must be a plist."))
|
||||
|
||||
(defmethod execute-emb ((name t) &key env generator-maker)
|
||||
(funcall (get-emb-function name) :env env :generator-maker generator-maker :name name))
|
||||
|
||||
(defmethod execute-emb ((name pathname) &key env generator-maker)
|
||||
(let ((fun (or (get-emb-function name)
|
||||
(emb-function-function (register-emb name name)))))
|
||||
(funcall fun :env env :generator-maker generator-maker :name name)))
|
||||
|
||||
(defvar *functions* (make-hash-table :test #'equal)
|
||||
"Table mapping names to emb-function instances.")
|
||||
|
||||
(defclass emb-function ()
|
||||
((path :initarg :path
|
||||
:accessor emb-function-path)
|
||||
(time :initarg :time
|
||||
:accessor emb-function-time)
|
||||
(function :initarg :function
|
||||
:accessor emb-function-function)
|
||||
(form :initarg :form
|
||||
:initform nil
|
||||
:accessor emb-function-form)))
|
||||
|
||||
(defun make-emb-function (path time function &optional form)
|
||||
"Constructor for class EMB-FUNCTION."
|
||||
(make-instance 'emb-function
|
||||
:path path
|
||||
:time time
|
||||
:function function
|
||||
:form form))
|
||||
|
||||
|
||||
(defun pprint-emb-function (name)
|
||||
"DEBUG function. Pretty prints function form, if *DEBUG* was t
|
||||
when the function was registered."
|
||||
(with-lock
|
||||
(pprint (emb-function-form (gethash name *functions*)))))
|
||||
|
||||
|
||||
(defun clear-emb-all ()
|
||||
"Remove all registered emb code."
|
||||
(with-lock
|
||||
(clrhash *functions*)))
|
||||
|
||||
(defun clear-emb (name)
|
||||
"Remove named emb code."
|
||||
(with-lock
|
||||
(remhash name *functions*)))
|
||||
|
||||
(defun clear-emb-all-files ()
|
||||
"Remove all registered file emb code (registered/executed by a pathname)."
|
||||
(with-lock
|
||||
(maphash (lambda (key value) (declare (ignore value))
|
||||
(when (typep key 'pathname) (remhash key *functions*)))
|
||||
*functions*)))
|
||||
|
||||
(defun get-emb-function (name)
|
||||
"Returns the named function implementing a registered emb code.
|
||||
Rebuilds it when text template was a file which has been modified."
|
||||
(with-lock
|
||||
(let* ((emb-function (gethash name *functions*))
|
||||
(path (when emb-function (emb-function-path emb-function))))
|
||||
(cond ((and (not (typep name 'pathname)) (null emb-function))
|
||||
(error "Function ~S not found." name))
|
||||
((null emb-function)
|
||||
(return-from get-emb-function))
|
||||
((and path
|
||||
(> (file-write-date path) (emb-function-time emb-function)))
|
||||
;; Update when file is newer
|
||||
(multiple-value-bind (function form)
|
||||
(construct-emb-function (contents-of-file path))
|
||||
(setf (emb-function-time emb-function) (file-write-date path)
|
||||
(emb-function-function emb-function) function
|
||||
(emb-function-form emb-function) form))))
|
||||
(emb-function-function emb-function))))
|
||||
|
||||
|
||||
(defgeneric register-emb (name code)
|
||||
(:documentation "Register given CODE as NAME."))
|
||||
|
||||
(defmethod register-emb (name (code pathname))
|
||||
(multiple-value-bind (function form)
|
||||
(construct-emb-function (contents-of-file code))
|
||||
(with-lock
|
||||
(setf (gethash name *functions*)
|
||||
(make-emb-function code
|
||||
(file-write-date code)
|
||||
function
|
||||
form)))))
|
||||
|
||||
(defmethod register-emb (name (code string))
|
||||
(multiple-value-bind (function form)
|
||||
(construct-emb-function code)
|
||||
(with-lock
|
||||
(setf (gethash name *functions*)
|
||||
(make-emb-function nil
|
||||
(get-universal-time)
|
||||
function
|
||||
form)))))
|
||||
|
||||
(defvar *emb-start-marker* "<%"
|
||||
"Start of scriptlet or expression. Remember that a following #\=
|
||||
indicates an expression.")
|
||||
|
||||
(defvar *emb-end-marker* "%>"
|
||||
"End of scriptlet or expression.")
|
||||
|
||||
|
||||
(defparameter *set-special-list*
|
||||
'(("escape" . "cl-emb:*escape-type*")
|
||||
("case-sensitivity" . "cl-emb:*case-sensitivity*")))
|
||||
|
||||
(defparameter *set-parameter-list*
|
||||
'(("xml" . ":xml")
|
||||
("html" . ":html")
|
||||
("url" . ":url")
|
||||
("uri" . ":uri")
|
||||
("url-encode" . ":url-encode")
|
||||
("raw" . ":raw")
|
||||
("latex" . ":latex")
|
||||
("t" . "t")
|
||||
("nil" . "nil")))
|
||||
|
||||
;; TODO: Refactor! Looks a bit clumsy.
|
||||
(defun set-specials (match &rest registers)
|
||||
"Parse parameter(s) of @set and set special variables
|
||||
like e. g. *ESCAPE-TYPE*."
|
||||
;; <% @set escape=xml schnuffel=poe %>
|
||||
(declare (ignore match))
|
||||
(let ((setf-pairs
|
||||
(let ((setf-list nil))
|
||||
(dolist (pair (cl-ppcre:split "\\s+" (first registers))
|
||||
(when (first setf-list)
|
||||
(format nil "~{ ~A~}" (reverse setf-list))))
|
||||
(destructuring-bind (left right)
|
||||
(cl-ppcre:split "=" pair)
|
||||
(let ((place (rest (assoc left *set-special-list* :test #'equalp)))
|
||||
(value (rest (assoc right *set-parameter-list* :test #'equalp))))
|
||||
(when (and place value)
|
||||
(push (concatenate 'string place " " value) setf-list))))))))
|
||||
(if setf-pairs
|
||||
(format nil "(setf ~A)" setf-pairs)
|
||||
"")))
|
||||
|
||||
(defparameter *template-tag-expand*
|
||||
`(("\\s+@if\\s+(\\S+)\\s*" . " (cond ((cl-emb::autofuncall (cl-emb::getf-emb \"\\1\")) ")
|
||||
("\\s+@ifnotempty\\s+(\\S+)\\s*" . " (cond ((let* ((value (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\")))) (or (numberp value) (> (length value) 0))) ")
|
||||
("\\s+@ifequal\\s+(\\S+)\\s+(\\S+)\\s*" . " (cond ((equal (format nil \"~a\" (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\"))) (format nil \"~a\" (cl-emb::autofuncall (cl-emb::getf-emb \"\\2\")))) ")
|
||||
("\\s+@else\\s*" . " ) (t ")
|
||||
("\\s+@endif\\s*" . " )) ")
|
||||
("\\s+@unless\\s+(\\S+)\\s*" . " (cond ((not (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\"))) ")
|
||||
("\\s+@endunless\\s*" . " )) ")
|
||||
("=?\\s+@var\\s+(\\S+)\\s+-(\\S+)\\s+(\\S+)\\s*"
|
||||
. "= (cl-emb::echo (cl-emb::getf-emb \"\\1\") :\\2 :\\3) ")
|
||||
("=?\\s+@var\\s+(\\S+)\\s*" . "= (cl-emb::echo (cl-emb::getf-emb \"\\1\")) ")
|
||||
("\\s+@repeat\\s+(\\d+)\\s*" . " (dotimes (i \\1) ")
|
||||
("\\s+@repeat\\s+(\\S+)\\s*" . " (dotimes (i (or (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\")) 0)) ")
|
||||
("\\s+@endrepeat\\s*" . " ) ")
|
||||
("\\s+@loop\\s+(\\S+)\\s*" . " (dolist (env (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\"))) ")
|
||||
("\\s+@endloop\\s*" . " ) ")
|
||||
("\\s+@genloop\\s+(\\S+)\\s*" . " (let ((env)
|
||||
(%gen (funcall generator-maker :\\1
|
||||
(cl-emb::getf-emb \"\\1\"))))
|
||||
(loop
|
||||
(when (funcall %gen :test) (return))
|
||||
(setq env (funcall %gen :next))
|
||||
(progn ")
|
||||
("\\s+@endgenloop\\s*" . " ))) ")
|
||||
("\\s+@with\\s+(\\S+)\\s*" . " (let ((env (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\")))) ")
|
||||
("\\s+@endwith\\s*" . " ) ")
|
||||
("\\s+@include\\s+(\\S+)\\s*" . "= (let ((cl-emb:*escape-type* cl-emb:*escape-type*))
|
||||
(cl-emb:execute-emb (merge-pathnames \"\\1\" template-path-default) :env env :generator-maker generator-maker)) ")
|
||||
("\\s+@includevar\\s+(\\S+)\\s*" . "= (let* ((cl-emb:*escape-type* cl-emb:*escape-type*)
|
||||
(parameter (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\"))))
|
||||
(unless parameter (error \"use of @includevar on undefined parameter ~s\" \"\\1\"))
|
||||
(cl-emb:execute-emb (merge-pathnames parameter template-path-default) :env env :generator-maker generator-maker)) ")
|
||||
("\\s+@call\\s+(\\S+)\\s*" . "= (let ((cl-emb:*escape-type* cl-emb:*escape-type*))
|
||||
(cl-emb:execute-emb \"\\1\" :env env :generator-maker generator-maker)) ")
|
||||
("\\s+@insert\\s+(\\S+)\\s*" . "= (cl-emb::contents-of-file (merge-pathnames (cl-emb::autofuncall (cl-emb::getf-emb \"\\1\")) template-path-default)) ")
|
||||
("\\s+@set\\s+(.*?)\\s*" . ,(function set-specials))
|
||||
("#.*" . "")
|
||||
)
|
||||
"List of conses. FIRST is regex, REST replacement (STRING or FUNCTION).
|
||||
Functions get called with two parameters: match and list of registers.")
|
||||
|
||||
;; Code from Edi Weitz's TBNL <http://weitz.de/tbnl/>
|
||||
(defun escape-for-xml (string)
|
||||
(with-output-to-string (out)
|
||||
(with-input-from-string (in string)
|
||||
(loop for char = (read-char in nil nil)
|
||||
while char
|
||||
do (case char
|
||||
((#\<) (write-string "<" out))
|
||||
((#\>) (write-string ">" out))
|
||||
((#\") (write-string """ out))
|
||||
((#\') (write-string "'" out))
|
||||
((#\&) (write-string "&" out))
|
||||
(otherwise (write-char char out)))))))
|
||||
|
||||
(defun escape-by-table (string replacements)
|
||||
(with-output-to-string (out)
|
||||
(with-input-from-string (in string)
|
||||
(loop for char = (read-char in nil nil)
|
||||
while char
|
||||
do (let ((new (find char replacements
|
||||
:test 'equal
|
||||
:key 'car)))
|
||||
(if new
|
||||
(write-string (cdr new) out)
|
||||
(write-char char out))
|
||||
)))))
|
||||
|
||||
(defvar *latex-replacements*)
|
||||
(setf *latex-replacements*
|
||||
(mapcar
|
||||
(lambda (x) `(,(character (car x)) . ,(cdr x)))
|
||||
`(
|
||||
("#" . "\\#")
|
||||
("$" . "\\$")
|
||||
("%" . "\\%")
|
||||
("&" . "\\&")
|
||||
("_" . "\\_")
|
||||
("{" . "\\{")
|
||||
("}" . "\\}")
|
||||
("<" . "{$<$}")
|
||||
(">" . "{$>$}")
|
||||
("\\" . "{$\\backslash{}$}")
|
||||
("|" . "{$\\vert{}$}")
|
||||
("~" . "{\\,$\\tilde{}$\\,}")
|
||||
("^" . "{\\,$\\hat{}$\\,}")
|
||||
(,(string #\Return) . "~\\\\")
|
||||
(,(string #\NewLine) . "~\\\\")
|
||||
("\"" . "{'{}'}")
|
||||
(,(string (code-char 173)) . "\\-") ; Soft hyphen
|
||||
(,(string (code-char 160)) . "~") ; No-break space
|
||||
(,(string (code-char 8209)) . "-") ; Non-breaking hyphen
|
||||
(,(string (code-char 8211)) . "--") ; En-dash
|
||||
(,(string (code-char 8212)) . "---") ; Em-dash
|
||||
(,(string (code-char 8470)) . "{\\textnumero}") ; Number sign
|
||||
)))
|
||||
|
||||
(defun escape-for-latex (string)
|
||||
(escape-by-table string
|
||||
*latex-replacements*))
|
||||
|
||||
;; Inspired by Edi Weitz' ESCAPE-FOR-HTML
|
||||
(defun url-encode (string)
|
||||
"URL-encode a string."
|
||||
(with-output-to-string (out)
|
||||
(with-input-from-string (in string)
|
||||
(loop for char = (read-char in nil nil)
|
||||
while char
|
||||
if (find char "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_-.")
|
||||
do (write-char char out)
|
||||
else if (char= char #\Space)
|
||||
do (write-char #\+ out)
|
||||
else
|
||||
do (format out "%~2,'0x" (char-code char))))))
|
||||
|
||||
|
||||
(defvar *case-sensitivity* nil
|
||||
"Whether use case-sensitive mode (the default) or case-insensitive mode. If this is set NIL, the case of keys in ENV will be ignored.")
|
||||
|
||||
(defun string-to-keyword (string)
|
||||
"Interns a given STRING uppercased in the keyword package."
|
||||
(nth-value 0 (intern
|
||||
(if *case-sensitivity*
|
||||
string
|
||||
(string-upcase string)) :keyword)))
|
||||
|
||||
(defgeneric getf* (thing key &optional default)
|
||||
(:documentation "Returns a value by a key"))
|
||||
|
||||
(defmethod getf* ((plist list) key &optional default)
|
||||
"Uses getf to get a value from a plist"
|
||||
(if *case-sensitivity*
|
||||
(getf plist key default)
|
||||
(loop for (k v) on plist by #'cddr
|
||||
when (string-equal k key)
|
||||
do (return v)
|
||||
finally (return default))))
|
||||
|
||||
(defmethod getf* ((table hash-table) key &optional default)
|
||||
"Uses gethash to get a value from a hash-table"
|
||||
(gethash key table default))
|
||||
|
||||
(defmethod getf* ((object standard-object) key &optional default)
|
||||
"Uses slot-value to get a value from a standard object, where the slot name is derived from key"
|
||||
(let ((slot-name (intern (princ-to-string key)
|
||||
(symbol-package (class-name (class-of object))))))
|
||||
(if (and (slot-exists-p object slot-name)
|
||||
(slot-boundp object slot-name))
|
||||
(slot-value object slot-name)
|
||||
default)))
|
||||
|
||||
(defmacro getf-emb (key)
|
||||
"Search either plist TOPENV or ENV according to the search path in KEY. KEY
|
||||
is a string."
|
||||
(let ((plist (if (char= (char key 0) #\/)
|
||||
(find-symbol "TOPENV" emb:*function-package*)
|
||||
(find-symbol "ENV" emb:*function-package*)))
|
||||
(path-parts (cl-ppcre:split "/" key :sharedp t)))
|
||||
(labels ((dig-plist (plist keys)
|
||||
(if (null keys)
|
||||
plist
|
||||
(dig-plist
|
||||
(if (zerop (length (first keys)))
|
||||
plist
|
||||
`(getf* ,plist ,(string-to-keyword (first keys))))
|
||||
(rest keys)))))
|
||||
(dig-plist plist path-parts))))
|
||||
|
||||
(defvar *escape-type* :raw
|
||||
"Default value for escaping @var output.")
|
||||
|
||||
(defun autofuncall (v)
|
||||
(if (functionp v)
|
||||
(autofuncall (funcall v))
|
||||
v))
|
||||
|
||||
(defun echo (string &key (escape *escape-type*))
|
||||
"Emit given STRING. Escape if wanted (global or via ESCAPE keyword).
|
||||
STRING can be NIL."
|
||||
(let ((str (cond
|
||||
((stringp string) string)
|
||||
((null string) "")
|
||||
((functionp string)
|
||||
(format nil "~a" (or (autofuncall string) "")))
|
||||
(t (format nil "~a" string))
|
||||
)))
|
||||
(case escape
|
||||
((:html :xml)
|
||||
(escape-for-xml str))
|
||||
((:latex)
|
||||
(escape-for-latex str))
|
||||
((:url :uri :url-encode)
|
||||
(url-encode str))
|
||||
(otherwise ; incl. :raw
|
||||
str))))
|
||||
|
||||
(defun insert-file (filename)
|
||||
"Get given file FILENAME."
|
||||
(contents-of-file filename))
|
||||
|
||||
(let ((scanner-hash (make-hash-table :test #'equal)))
|
||||
(defun scanner-for-expand-template-tag (tag)
|
||||
"Returns a CL-PPCRE scanner which matches a template tag expanded by EXPAND-TEMPLATE-TAGS.
|
||||
Scanners are memoized in SCANNER-HASH once they are created."
|
||||
(or (gethash tag scanner-hash)
|
||||
(setf (gethash tag scanner-hash)
|
||||
(ppcre:create-scanner tag))))
|
||||
(defun clear-expand-template-tag-hash ()
|
||||
"Removes all scanners for template tags from cache."
|
||||
(clrhash scanner-hash)))
|
||||
|
||||
(defun expand-template-tags (string)
|
||||
"Expand template-tags (@if, @else, ...) to Common Lisp.
|
||||
Replacement and regex in *TEMPLATE-TAG-EXPAND*"
|
||||
(labels ((expand-tags (string &optional (expands *template-tag-expand*))
|
||||
(let ((regex (scanner-for-expand-template-tag
|
||||
(concatenate 'string "(?is)"
|
||||
"^" (first (first expands)) "$")))
|
||||
(replacement (rest (first expands))))
|
||||
(if (null (rest expands))
|
||||
(ppcre:regex-replace-all regex string replacement :simple-calls t)
|
||||
(expand-tags
|
||||
(ppcre:regex-replace-all regex string replacement :simple-calls t)
|
||||
(rest expands))))))
|
||||
(ppcre:regex-replace-all (format nil "(?is)(~A\\-?)(.+?)(\\-?~A)"
|
||||
(ppcre:quote-meta-chars *emb-start-marker*)
|
||||
(ppcre:quote-meta-chars *emb-end-marker*))
|
||||
string
|
||||
(lambda (match start-tag string end-tag)
|
||||
(declare (ignore match))
|
||||
(if (ppcre:scan "(?is)^#.+#$" string)
|
||||
""
|
||||
(concatenate 'string
|
||||
start-tag
|
||||
(expand-tags string)
|
||||
end-tag)))
|
||||
:simple-calls t)))
|
||||
|
||||
(defvar *emb-stream-redirection* "with-output-to-string (*standard-output*)")
|
||||
|
||||
(defun construct-emb-function (code)
|
||||
"Builds and compiles the emb-function out of template code."
|
||||
(let ((form
|
||||
`,(let ((*package* *function-package*))
|
||||
(read-from-string
|
||||
(format nil "(lambda (&key env generator-maker name)(declare (ignorable env generator-maker))
|
||||
(let ((topenv env)
|
||||
(template-path-default (if (typep name 'pathname) name *default-pathname-defaults*)))
|
||||
(declare (ignorable topenv template-path-default))
|
||||
(~a
|
||||
(progn ~A))))"
|
||||
*emb-stream-redirection*
|
||||
(construct-emb-body-string
|
||||
(expand-template-tags code)))))))
|
||||
(values (compile nil form)
|
||||
(when *debug* form))))
|
||||
|
||||
(defun contents-of-file (pathname)
|
||||
"Returns a string with the entire contents of the specified file."
|
||||
(with-open-file (in pathname :direction :input)
|
||||
;; See http://www.emmett.ca/~sabet/licensets/slurp.html
|
||||
(let* ((file-length (file-length in))
|
||||
(seq (make-string file-length))
|
||||
(pos (read-sequence seq in)))
|
||||
(if (< pos file-length)
|
||||
(subseq seq 0 pos)
|
||||
seq))))
|
||||
|
||||
(defun string-right-trim-spaces-until-newline (string)
|
||||
(remove #\Newline (string-right-trim '(#\Space #\Tab) string)
|
||||
:from-end t
|
||||
:count 1))
|
||||
|
||||
;; (i) Converts text outside <% ... %> tags into calls
|
||||
;; to WRITE-STRING, (ii) Text inside <% ... %>
|
||||
;; ("scriptlets") is straight lisp code, (iii) Text inside <%= ... %>
|
||||
;; ("expressions") becomes the argument to (FORMAT t "~A" ...)
|
||||
;; The markers <% and %> can be overridden by setting
|
||||
;; *emb-start-marker* and *emb-end-marker*
|
||||
(defun construct-emb-body-string (code &optional (start 0))
|
||||
"Takes a string containing an emb code and returns a string
|
||||
containing the lisp code that implements that emb code."
|
||||
(multiple-value-bind (start-tag start-code tag-type trim-start-whitespaces)
|
||||
(next-code code start)
|
||||
(if (not start-tag)
|
||||
(format nil "(write-string ~S)" (subseq code start))
|
||||
(let* ((end-code (search *emb-end-marker* code :start2 start-code))
|
||||
(trim-end-whitespaces (char= (char code (1- end-code)) #\-)))
|
||||
(if (not end-code)
|
||||
(error "EOF reached in EMB inside open '~A' tag." *emb-start-marker*)
|
||||
(format nil "(write-string ~S) ~A ~A"
|
||||
(if trim-start-whitespaces
|
||||
(string-right-trim-spaces-until-newline (subseq code start start-tag))
|
||||
(subseq code start start-tag))
|
||||
(format nil (tag-template tag-type)
|
||||
(subseq code start-code (if trim-end-whitespaces
|
||||
(1- end-code)
|
||||
end-code)))
|
||||
(construct-emb-body-string
|
||||
code
|
||||
(if trim-end-whitespaces
|
||||
(let ((next-pos (cl-ppcre:scan "(?:\\S|\\n)" code :start (+ end-code (length *emb-end-marker*)))))
|
||||
(cond
|
||||
((null next-pos) (length code))
|
||||
((char= (elt code next-pos) #\Newline)
|
||||
(1+ next-pos))
|
||||
(t next-pos)))
|
||||
(+ end-code (length *emb-end-marker*))))))))))
|
||||
|
||||
|
||||
;; Finds the next scriptlet or expression tag in EMB source. Returns
|
||||
;; nil if none are found, otherwise returns 3 values:
|
||||
;; 1. The position of the first character of the start tag.
|
||||
;; 2. The position of the contents of the tag.
|
||||
;; 3. The type of tag (:scriptlet or :expression).
|
||||
;; 4. Whether trim whitespaces before the start tag.
|
||||
(defun next-code (string start)
|
||||
(let ((start-tag (search *emb-start-marker* string :start2 start)))
|
||||
(if (not start-tag)
|
||||
nil
|
||||
(let ((start-code (+ start-tag (length *emb-start-marker*))))
|
||||
(case (and (> (length string) start-code)
|
||||
(char string start-code))
|
||||
(#\= (values start-tag (1+ start-code) :expression nil))
|
||||
(#\- (values start-tag (1+ start-code) :scriptlet t))
|
||||
(otherwise (values start-tag start-code :scriptlet nil)))))))
|
||||
|
||||
|
||||
;; Given a tag type (:scriptlet or :expression), returns a format
|
||||
;; string to be used to generate source code from the contents of the
|
||||
;; tag.
|
||||
(defun tag-template (tag-type)
|
||||
(ecase tag-type
|
||||
((:scriptlet) "~A")
|
||||
((:expression) "(format t \"~~A\" ~A)")))
|
||||
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
|
||||
body { font-family: sans-serif;
|
||||
background-color: #fff;
|
||||
color: #000; }
|
||||
|
||||
pre { margin-top: 0;
|
||||
margin-bottom: 0; }
|
||||
|
||||
table { width: 100%; }
|
||||
|
||||
th, td { text-align: left;
|
||||
vertical-align: top; }
|
||||
|
||||
th { background-color: #eee; }
|
||||
|
||||
caption { font-weight: bold; }
|
||||
|
||||
table, ol { margin-bottom: 2em; }
|
||||
|
|
@ -0,0 +1,232 @@
|
|||
<?xml version="1.0" encoding="utf-8"?>
|
||||
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
|
||||
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
|
||||
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
|
||||
<head>
|
||||
<link href="examples.css" rel="stylesheet" type="text/css" />
|
||||
<title>CL-EMB: Examples</title>
|
||||
</head>
|
||||
<body>
|
||||
<h1>Some examples of <a href="http://common-lisp.net/project/cl-emb/">CL-EMB</a> usage</h1>
|
||||
<ol>
|
||||
<li><a href="#combine-cl-who">Combining CL-EMB with CL-WHO</a></li>
|
||||
<li><a href="#simple-loop">A simple loop</a></li>
|
||||
<li><a href="#build-dropdown">Build a dropdown</a></li>
|
||||
<li><a href="#mark-fields">Mark invalid form fields</a></li>
|
||||
<li><a href="#using-generic-templates">Using generic templates</a></li>
|
||||
</ol>
|
||||
<table border="1" cellpadding="2" id="combine-cl-who">
|
||||
<caption>Combining CL-EMB with CL-WHO</caption>
|
||||
<tr>
|
||||
<th>
|
||||
Description
|
||||
</th>
|
||||
<td>
|
||||
You can mix several methods of HTML generating together. Think of <a href="http://www.cliki.net/Lisp%20Markup%20Languages">Lisp Markup Languages</a> like <a href="http://weitz.de/cl-who/">CL-WHO</a>. <small>(Example code from the <a href="http://weitz.de/cl-who/">CL-WHO</a> documentation.)</small>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th>
|
||||
ENV
|
||||
</th>
|
||||
<td>
|
||||
<code>NIL</code>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th>
|
||||
Dependencies
|
||||
</th>
|
||||
<td>
|
||||
<a href="http://weitz.de/cl-who/">CL-WHO</a>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td colspan="2">
|
||||
<pre><h1>Music links</h1>
|
||||
<%
|
||||
(cl-who:with-html-output (*standard-output*)
|
||||
(loop for (link . title) in
|
||||
'(("http://zappa.com/" . "Frank Zappa")
|
||||
("http://marcusmiller.com/" . "Marcus Miller")
|
||||
("http://www.milesdavis.com/" . "Miles Davis"))
|
||||
do (cl-who:htm (:a :href link
|
||||
(:b (cl-who:str title)))
|
||||
:br)))
|
||||
%></pre>
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
|
||||
<table border="1" cellpadding="2" id="simple-loop">
|
||||
<caption>A simple loop</caption>
|
||||
<tr>
|
||||
<th>
|
||||
Description
|
||||
</th>
|
||||
<td>
|
||||
The "Music links" example with template tags and a loop. This example isn't meant to prove anything! Use the method which fits your problem!<br/>
|
||||
The output of the title gets escaped by CL-EMB ("-escape html"). Depending on the situation you'd rather escape the output yourself and don't want to use any complicated modifiers in the template code itself.
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th>
|
||||
ENV
|
||||
</th>
|
||||
<td>
|
||||
<pre>'(:music-list
|
||||
((:link "http://zappa.com/" :title "Frank Zappa")
|
||||
(:link "http://marcusmiller.com/" :title "Marcus Miller")
|
||||
(:link "http://www.milesdavis.com/" :title "Miles Davis")))</pre>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th>
|
||||
Dependencies
|
||||
</th>
|
||||
<td>
|
||||
-
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td colspan="2">
|
||||
<pre><h1>Music links</h1>
|
||||
<% @loop music-list %>
|
||||
<a href="<% @var link %>"><b><% @var title -escape html%></b></a><br />
|
||||
<% @endloop %></pre>
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
|
||||
<table border="1" cellpadding="2" id="build-dropdown">
|
||||
<caption>Build a dropdown</caption>
|
||||
<tr>
|
||||
<th>
|
||||
Description
|
||||
</th>
|
||||
<td>
|
||||
You can mix template style with embedded Common Lisp style. This example shows how to access the plist ENV. Within the loop (<code >@loop</code>) ENV gets bound to every plist in the list.<br/>
|
||||
<a href="http://weitz.de/tbnl/">TBNL</a> is used to access a submitted parameter "product" and compare it to the current value attribute of the option element.<br/>
|
||||
Remember the escaping! Set <code>cl-emb:*escape-type*</code> to <code>:html</code> and all output of <code>@var</code> will be escaped correctly.
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th>
|
||||
ENV
|
||||
</th>
|
||||
<td>
|
||||
<pre>'(:products
|
||||
((:value "foo1" :text "Super Foo")
|
||||
(:value "fooxl" :text "Super Foo XL")
|
||||
(:value "bar2000" :text "Ultra Bar 2000")
|
||||
(:value "hl2" :text "Half-Life 2")
|
||||
(:value "dn4e4" :text "Vaporware")))</pre>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th>
|
||||
Dependencies
|
||||
</th>
|
||||
<td>
|
||||
<a href="http://weitz.de/tbnl/">TBNL</a>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td colspan="2">
|
||||
<pre><select name="product">
|
||||
<% @loop products %>
|
||||
<option value="<% @var value %>"<%
|
||||
(when (equal (getf env :value) (tbnl:parameter "product"))
|
||||
%> selected="selected"<% ) %>><% @var text %></option>
|
||||
<% @endloop %>
|
||||
</select></pre>
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
|
||||
<table border="1" cellpadding="2" id="mark-fields">
|
||||
<caption>Mark invalid form fields</caption>
|
||||
<tr>
|
||||
<th>
|
||||
Description
|
||||
</th>
|
||||
<td>
|
||||
Validate a form and mark the errors in the <em>ENV</em> plist.<br />
|
||||
Again: Remember the escaping!
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th>
|
||||
ENV
|
||||
</th>
|
||||
<td>
|
||||
<pre>'(:email "stesch@home" :email-error t)</pre>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th>
|
||||
Dependencies
|
||||
</th>
|
||||
<td>
|
||||
-
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td colspan="2">
|
||||
<pre><% @if email-error %>
|
||||
<span class="error">Please provide valid e-mail address</span><br />
|
||||
<% @endif %>
|
||||
<input type="text" name="email" value="<% @var email %>"/></pre>
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
|
||||
<table border="1" cellpadding="2" id="using-generic-templates">
|
||||
<caption>Using generic templates</caption>
|
||||
<tr>
|
||||
<th>
|
||||
Description
|
||||
</th>
|
||||
<td>
|
||||
You want to use generic templates which can be called with a defined set of parameters? Then <code>@with</code> and <code>@endwith</code> is what you are looking for. It sets the current <em>ENV</em> to the one accessed by a given name. See the example below, which calls a template for textinput fields.
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th>
|
||||
ENV
|
||||
</th>
|
||||
<td>
|
||||
<pre>'(:name (:name "name"
|
||||
:length 40)
|
||||
:e-mail (:name "email"
|
||||
:value "no@no"
|
||||
:error t
|
||||
:length 120))</pre>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<th>
|
||||
Dependencies
|
||||
</th>
|
||||
<td>
|
||||
-
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td colspan="2">
|
||||
<pre>Please enter your name:<br />
|
||||
<% @with name %>
|
||||
<% @include "includes/textinput.tmpl" %>
|
||||
<% @endwith %>
|
||||
<br />
|
||||
Please enter your e-mail address:<br />
|
||||
<small>(Use the TLD <em>.invalid</em>
|
||||
if you don't want to receive mail</small>
|
||||
<% @with e-mail %>
|
||||
<% @include "includes/textinput.tmpl" %>
|
||||
<% @endwith %></pre>
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
</body>
|
||||
</html>
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
|
||||
CL-EMB uses parts of LSP, written by John Wiseman.
|
||||
|
||||
See the copyright notice and license for LSP:
|
||||
|
||||
---8<---8<---8<---8<---8<---8<---8<---8<---8<---8<---8<---8<---8<---8<---
|
||||
|
||||
Copyright (c) 2001, 2002 I/NET Inc.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining
|
||||
a copy of this software and associated documentation files (the
|
||||
"Software"), to deal in the Software without restriction, including
|
||||
without limitation the rights to use, copy, modify, merge, publish,
|
||||
distribute, sublicense, and/or sell copies of the Software, and to
|
||||
permit persons to whom the Software is furnished to do so, subject to
|
||||
the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be
|
||||
included in all copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
||||
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
|
||||
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
|
||||
LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
|
||||
OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
|
||||
WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||
|
||||
;;; This software is Copyright (c) Stefan Scholl, 2004.
|
||||
;;; Stefan Scholl grants you the rights to distribute
|
||||
;;; and use this software as governed by the terms
|
||||
;;; of the Lisp Lesser GNU Public License
|
||||
;;; (http://opensource.franz.com/preamble.html),
|
||||
;;; known as the LLGPL.
|
||||
|
||||
|
||||
(in-package #:cl-user)
|
||||
|
||||
(defpackage #:cl-emb
|
||||
(:nicknames #:emb)
|
||||
(:use #:cl)
|
||||
(:export #:execute-emb
|
||||
#:register-emb
|
||||
#:pprint-emb-function
|
||||
#:clear-emb
|
||||
#:clear-emb-all
|
||||
#:clear-emb-all-files
|
||||
#:clear-expand-template-tag-hash
|
||||
#:*debug*
|
||||
#:*emb-start-marker*
|
||||
#:*emb-end-marker*
|
||||
#:*escape-type*
|
||||
#:*case-sensitivity*
|
||||
#:*locking-function*
|
||||
#:*function-package*
|
||||
#:getf*
|
||||
#:construct-emb-function ))
|
||||
|
|
@ -0,0 +1,121 @@
|
|||
Version 0.7.6
|
||||
2019-07-28
|
||||
Clisp has renamed ext:delete-dir to ext:delete-directory.
|
||||
Fix get-default-temporary-directory on lispworks.
|
||||
|
||||
Version 0.7.5
|
||||
2017-12-10
|
||||
Fix FILE-EXISTS-P to return directory truename in CLISP (chaitanyagupta)
|
||||
Added support for Common Lisp implementation CLASP. (dg1sbg)
|
||||
|
||||
Version 0.7.4
|
||||
2016-07-10
|
||||
Merge pull request #13 from vibs29/master (Hans Hübner)
|
||||
Make copy-stream work for CMUCL Gray Streams (vibs29)
|
||||
|
||||
Version 0.7.3
|
||||
2014-11-28
|
||||
remove version from cl-fad-test system (Hans Huebner)
|
||||
update support information (Hans Huebner)
|
||||
|
||||
Version 0.7.2
|
||||
2013-07-03
|
||||
Fix documentation glitch (inconsistent download link) (Luís Oliveira)
|
||||
|
||||
Version 0.7.1
|
||||
2013-02-18
|
||||
Fix for LispWorks (R. Wilker)
|
||||
Add :description to .asd file
|
||||
|
||||
Version 0.7.0
|
||||
2013-01-23
|
||||
Tests, pathname manipulation functions (Marco Baringer)
|
||||
Temporary files (merged by Marco Baringer)
|
||||
Fix symlink behaviour for some platforms (Mihai Bazon and Janis Dzerins)
|
||||
|
||||
Version 0.6.4
|
||||
2010-11-18
|
||||
Adapt to newer ClozureCL version (patch from Zach Beane, thanks to Chun Tian and Ralph Moritz as well)
|
||||
|
||||
Version 0.6.3
|
||||
2009-09-30
|
||||
Removed dependency on :SB-EXECUTABLE (thanks to Attila Lendvai and Tobias Rittweiler)
|
||||
|
||||
Version 0.6.2
|
||||
2008-03-12
|
||||
Never version of OpenMCL have %RMDIR (thanks to Dmitri Hrapof)
|
||||
|
||||
Version 0.6.1
|
||||
2007-12-29
|
||||
Integrated CLISP patch for LIST-DIRECTORY sent by Dan Muller
|
||||
|
||||
Version 0.6.0
|
||||
2007-05-28
|
||||
Support for Scieneer CL (patch from Douglas Crosher)
|
||||
|
||||
Version 0.5.2
|
||||
2007-05-15
|
||||
Fix for (newer versions of) ECL (patch from Dustin Long)
|
||||
|
||||
Version 0.5.1
|
||||
2006-08-11
|
||||
Added CHECKP to COPY-STREAM
|
||||
|
||||
Version 0.5.0
|
||||
2006-04-21
|
||||
Added :BREADTH-FIRST option to WALK-DIRECTORY (thanks to Mac Chan)
|
||||
|
||||
Version 0.4.3
|
||||
2006-03-15
|
||||
For CMUCL use TRUENAME with UNIX-RMDIR to cope with search lists (reported by Pawel Ostrowski)
|
||||
|
||||
Version 0.4.2
|
||||
2006-01-04
|
||||
WALK-DIRECTORY now catches circular symbolic links (thanks to Gary King)
|
||||
|
||||
Version 0.4.1
|
||||
2006-01-03
|
||||
Be more careful in DIRECTORY-WILDCARD (thanks to Gary King)
|
||||
Patches for MCL (thanks to Gary King)
|
||||
|
||||
Version 0.4.0
|
||||
2005-12-10
|
||||
Exported COPY-STREAM (suggested by Chris Dean)
|
||||
|
||||
Version 0.3.3
|
||||
2005-11-14
|
||||
Fixed %RMDIR for newer versions of OpenMCL (thanks to James Bielman)
|
||||
|
||||
Version 0.3.2
|
||||
2005-09-11
|
||||
Fixed docs (correct name DELETE-DIRECTORY-AND-FILES)
|
||||
Fixed docs (OVERWRITE was missing in COPY-FILE signature)
|
||||
Added Debian link
|
||||
|
||||
Version 0.3.1
|
||||
2005-06-02
|
||||
Fixed typo in fad.lisp (thanks to Jack D. Unrue)
|
||||
|
||||
Version 0.3.0
|
||||
2005-06-01
|
||||
Support for ABCL (thanks to Jack D. Unrue)
|
||||
|
||||
Version 0.2.0
|
||||
2005-05-29
|
||||
Support for ECL (thanks to Maciek Pasternacki)
|
||||
|
||||
Version 0.1.3
|
||||
2005-04-27
|
||||
Changed implementation of DIRECTORY-EXISTS-P for LispWorks
|
||||
|
||||
Version 0.1.2
|
||||
2005-03-17
|
||||
Fixed typo in cl-fad.system (tanks to Andrew Philpot)
|
||||
|
||||
Version 0.1.1
|
||||
2005-01-22
|
||||
Fixed typos and versioning
|
||||
|
||||
Version 0.1.0
|
||||
2005-01-22
|
||||
Initial release
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
;;; Copyright (c) 2004, Peter Seibel. All rights reserved.
|
||||
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
|
||||
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
|
||||
;;; * Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
|
||||
;;; * Redistributions in binary form must reproduce the above
|
||||
;;; copyright notice, this list of conditions and the following
|
||||
;;; disclaimer in the documentation and/or other materials
|
||||
;;; provided with the distribution.
|
||||
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS 'AS IS' AND ANY EXPRESSED
|
||||
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
||||
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
||||
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
||||
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
||||
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
Complete documentation for CL-FAD can be found in the 'docs'
|
||||
directory or at <https://edicl.github.io/cl-fad/>.
|
||||
|
||||
CL-FAD also supports Nikodemus Siivola's HYPERDOC, see
|
||||
<http://common-lisp.net/project/hyperdoc/> and
|
||||
<http://www.cliki.net/hyperdoc>.
|
||||
|
||||
1. Installation
|
||||
|
||||
1.1. Probably the easiest way is
|
||||
|
||||
(load "/path/to/cl-fad/load.lisp")
|
||||
|
||||
This should compile and load CL-FAD on most Common Lisp
|
||||
implementations.
|
||||
|
||||
1.2. With MK:DEFSYSTEM you can make a symbolic link from
|
||||
'cl-fad.system' and 'cl-fad-test.system' to your central registry
|
||||
(which by default is in '/usr/local/lisp/Registry/') and then issue
|
||||
the command
|
||||
|
||||
(mk:compile-system "cl-fad")
|
||||
|
||||
Note that this relies on TRUENAME returning the original file a
|
||||
symbolic link is pointing to. This will only work with AllegroCL
|
||||
6.2 if you've applied all patches with (SYS:UPDATE-ALLEGRO).
|
||||
|
||||
1.3. You can also use ASDF instead of MK:DEFSYSTEM in a similar way
|
||||
(use the .asd files instead of the .system files).
|
||||
|
||||
1.4. Via QuickLisp:
|
||||
|
||||
(ql:quickload :cl-fad)
|
||||
|
||||
2. Test
|
||||
|
||||
CL-FAD comes with a small test suite. To start it just load the file
|
||||
"test.lisp" and evaluate (CL-FAD-TEST:TEST).
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/cl-fad/cl-fad.asd,v 1.21 2009/09/30 14:23:09 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
|
||||
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
|
||||
;;; * Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
|
||||
;;; * Redistributions in binary form must reproduce the above
|
||||
;;; copyright notice, this list of conditions and the following
|
||||
;;; disclaimer in the documentation and/or other materials
|
||||
;;; provided with the distribution.
|
||||
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
|
||||
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
||||
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
||||
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
||||
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
||||
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
#+:allegro (cl:require :osi)
|
||||
|
||||
(asdf:defsystem #:cl-fad
|
||||
:version "0.7.6"
|
||||
:description "Portable pathname library"
|
||||
:serial t
|
||||
:license "BSD-2-Clause"
|
||||
:components ((:file "packages")
|
||||
#+:cormanlisp (:file "corman")
|
||||
#+:openmcl (:file "openmcl")
|
||||
(:file "fad")
|
||||
(:file "path" :depends-on ("fad"))
|
||||
(:file "temporary-files" :depends-on ("fad")))
|
||||
:depends-on (#+sbcl :sb-posix :bordeaux-threads :alexandria))
|
||||
|
||||
(asdf:defsystem #:cl-fad-test
|
||||
:serial t
|
||||
:components ((:file "packages.test")
|
||||
(:file "fad.test" :depends-on ("packages.test"))
|
||||
(:file "temporary-files.test" :depends-on ("packages.test")))
|
||||
:depends-on (:cl-fad :unit-test :cl-ppcre))
|
||||
|
|
@ -0,0 +1,48 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/cl-fad/cl-fad.system,v 1.8 2008/03/12 00:10:43 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved.
|
||||
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
|
||||
;;; * Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
|
||||
;;; * Redistributions in binary form must reproduce the above
|
||||
;;; copyright notice, this list of conditions and the following
|
||||
;;; disclaimer in the documentation and/or other materials
|
||||
;;; provided with the distribution.
|
||||
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
|
||||
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
||||
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
||||
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
||||
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
||||
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
(in-package #:cl-user)
|
||||
|
||||
(defparameter *cl-fad-base-directory*
|
||||
(make-pathname :name nil :type nil :version nil
|
||||
:defaults (parse-namestring *load-truename*)))
|
||||
|
||||
#+:allegro (require :osi)
|
||||
#+:sbcl (require :sb-executable)
|
||||
#+:sbcl (require :sb-posix)
|
||||
|
||||
(mk:defsystem #:cl-fad
|
||||
:source-pathname *cl-fad-base-directory*
|
||||
:source-extension "lisp"
|
||||
:components ((:file "packages")
|
||||
#+:cormanlisp (:file "corman" :depends-on ("packages"))
|
||||
#+:openmcl (:file "openmcl" :depends-on ("packages"))
|
||||
(:file "fad" :depends-on ("packages"
|
||||
#+:cormanlisp "corman"
|
||||
#+:openmcl "openmcl"))))
|
||||
|
|
@ -0,0 +1,86 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/cl-fad/corman.lisp,v 1.5 2009/09/30 14:23:09 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
|
||||
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
|
||||
;;; * Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
|
||||
;;; * Redistributions in binary form must reproduce the above
|
||||
;;; copyright notice, this list of conditions and the following
|
||||
;;; disclaimer in the documentation and/or other materials
|
||||
;;; provided with the distribution.
|
||||
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS 'AS IS' AND ANY EXPRESSED
|
||||
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
||||
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
||||
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
||||
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
||||
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
(in-package :cl)
|
||||
|
||||
(defun wild-pathname-p (pathspec &optional field)
|
||||
(unless (pathnamep pathspec)
|
||||
(setq pathspec (pathname pathspec)))
|
||||
(labels ((name-wild-p (name)
|
||||
(or (eq :wild name)
|
||||
(and (stringp name)
|
||||
(string= "*" name))))
|
||||
(dir-wild-p (dir)
|
||||
(or (find :wild dir)
|
||||
(find :wild-inferiors dir)
|
||||
(find "*" dir :test #'string=))))
|
||||
(case field
|
||||
((:name)
|
||||
(name-wild-p (pathname-name pathspec)))
|
||||
((:type)
|
||||
(name-wild-p (pathname-type pathspec)))
|
||||
((:directory)
|
||||
(dir-wild-p (pathname-directory pathspec)))
|
||||
((nil)
|
||||
(or (name-wild-p (pathname-name pathspec))
|
||||
(name-wild-p (pathname-type pathspec))
|
||||
(dir-wild-p (pathname-directory pathspec))))
|
||||
(t nil))))
|
||||
|
||||
(defun file-namestring (pathspec)
|
||||
(flet ((string-list-for-component (component)
|
||||
(cond ((eq component :wild)
|
||||
(list "*"))
|
||||
(component
|
||||
(list component))
|
||||
(t nil))))
|
||||
(let* ((pathname (pathname pathspec))
|
||||
(name (pathnames::pathname-internal-name pathname))
|
||||
(type (pathnames::pathname-internal-type pathname)))
|
||||
(format nil "~{~A~}~{.~A~}"
|
||||
(string-list-for-component name)
|
||||
(string-list-for-component type)))))
|
||||
|
||||
(in-package :win32)
|
||||
|
||||
(defwinapi RemoveDirectory
|
||||
((lpPathName LPCSTR))
|
||||
:return-type BOOL
|
||||
:library-name "Kernel32"
|
||||
:entry-name "RemoveDirectoryA"
|
||||
:linkage-type :pascal)
|
||||
|
||||
(defun delete-directory (pathspec)
|
||||
"Deletes the empty directory denoted by the pathname designator
|
||||
PATHSPEC. Returns true if successful, NIL otherwise."
|
||||
(win:RemoveDirectory
|
||||
(ct:lisp-string-to-c-string
|
||||
(namestring (pathname pathspec)))))
|
||||
|
||||
(export 'delete-directory)
|
||||
|
|
@ -0,0 +1,700 @@
|
|||
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
|
||||
<html>
|
||||
|
||||
<head>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
|
||||
<title>CL-FAD - A portable pathname library for Common Lisp</title>
|
||||
<style type="text/css">
|
||||
pre { padding:5px; background-color:#e0e0e0 }
|
||||
h3, h4, h5 { text-decoration: underline; }
|
||||
a { text-decoration: none; padding: 1px 2px 1px 2px; }
|
||||
a:visited { text-decoration: none; padding: 1px 2px 1px 2px; }
|
||||
a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; }
|
||||
a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; }
|
||||
a.none { text-decoration: none; padding: 0; }
|
||||
a.none:visited { text-decoration: none; padding: 0; }
|
||||
a.none:hover { text-decoration: none; border: none; padding: 0; }
|
||||
a.none:focus { text-decoration: none; border: none; padding: 0; }
|
||||
a.noborder { text-decoration: none; padding: 0; }
|
||||
a.noborder:visited { text-decoration: none; padding: 0; }
|
||||
a.noborder:hover { text-decoration: none; border: none; padding: 0; }
|
||||
a.noborder:focus { text-decoration: none; border: none; padding: 0; }
|
||||
pre.none { padding:5px; background-color:#ffffff }
|
||||
</style>
|
||||
</head>
|
||||
|
||||
<body bgcolor=white>
|
||||
|
||||
<h2>CL-FAD - A portable pathname library for Common Lisp</h2>
|
||||
|
||||
<blockquote>
|
||||
<br> <br><h3><a name=abstract class=none>Abstract</a></h3>
|
||||
|
||||
CL-FAD (for "<font color=red>F</font>iles <font color=red>a</font>nd
|
||||
<font color=red>D</font>irectories") is a thin layer atop Common
|
||||
Lisp's standard pathname functions. It is intended to provide some
|
||||
unification between current CL implementations on Windows, OS X,
|
||||
Linux, and Unix. Most of the code was written by Peter Seibel for his book <a href="http://www.gigamonkeys.com/book/"><em>Practical Common Lisp</em></a>.
|
||||
|
||||
<p>
|
||||
|
||||
CL-FAD comes with a <a
|
||||
href="http://www.opensource.org/licenses/bsd-license.php">BSD-style
|
||||
license</a> so you can basically do with it whatever you want.
|
||||
|
||||
<p>
|
||||
<font color=red>Download shortcut:</font> <a href="http://weitz.de/files/cl-fad.tar.gz">http://weitz.de/files/cl-fad.tar.gz</a>.
|
||||
</blockquote>
|
||||
|
||||
<br> <br><h3><a class=none name="contents">Contents</a></h3>
|
||||
<ol>
|
||||
<li><a href="#download">Download and installation</a>
|
||||
<li><a href="#implementations">Supported Lisp implementations</a>
|
||||
<li><a href="#dictionary">The CL-FAD dictionary</a>
|
||||
<ol>
|
||||
<li><a href="#querying">Querying files, directories and pathnames</a>
|
||||
<ol>
|
||||
<li><a href="#directory-exists-p"><code>directory-exists-p</code> [function]</a>
|
||||
<li><a href="#directory-pathname-p"><code>directory-pathname-p</code> [function]</a>
|
||||
<li><a href="#file-exists-p"><code>file-exists-p</code> [function]</a>
|
||||
<li><a href="#pathname-absolute-p"><code>pathname-absolute-p</code> [function]</a>
|
||||
<li><a href="#pathname-equal"><code>pathname-equal</code> [function]</a>
|
||||
<li><a href="#pathname-relative-p"><code>pathname-relative-p</code> [function]</a>
|
||||
<li><a href="#pathname-root-p"><code>pathname-root-p</code> [function]</a>
|
||||
</ol> </li>
|
||||
<li><a href="#manipulating">Manipulating pathnames</a>
|
||||
<ol>
|
||||
<li><a href="#canonical-pathname"><code>canonical-pathname</code> [function]</a>
|
||||
<li><a href="#merge-pathnames-as-directory"><code>merge-pathnames-as-directory</code> [function]</a>
|
||||
<li><a href="#merge-pathnames-as-file"><code>merge-pathnames-as-file</code> [function]</a>
|
||||
<li><a href="#pathname-as-directory"><code>pathname-as-directory</code> [function]</a>
|
||||
<li><a href="#pathname-as-file"><code>pathname-as-file</code> [function]</a>
|
||||
<li><a href="#pathname-directory-pathname"><code>pathname-directory-pathname</code> [function]</a>
|
||||
<li><a href="#pathname-parent-directory"><code>pathname-parent-directory</code> [function]</a>
|
||||
</ol> </li>
|
||||
<li><a href="#traversing">Traversing directories</a>
|
||||
<ol>
|
||||
<li><a href="#list-directory"><code>list-directory</code> [function]</a>
|
||||
<li><a href="#walk-directory"><code>walk-directory</code> [function]</a>
|
||||
</ol> </li>
|
||||
<li><a href="#temporary-files">Temporary Files</a>
|
||||
<ol>
|
||||
<li><a href="#open-temporary"><code>open-temporary</code> [function]</a>
|
||||
<li><a href="#with-output-to-temporary-file"><code>with-output-to-temporary-file</code> [macro]</a>
|
||||
<li><a href="#with-open-temporary-file"><code>with-open-temporary-file</code> [macro]</a>
|
||||
<li><a href="#star-default-template-star"><code>*default-template*</code> [variable]</a>
|
||||
<li><a href="#cannot-create-temporary-file"><code>cannot-create-temporary-file</code> [condition]</a>
|
||||
<li><a href="#invalid-temporary-pathname-template"><code>invalid-temporary-pathname-template</code> [condition]</a>
|
||||
<li><a href="#missing-temp-environment-variable"><code>missing-temp-environment-variable</code> [condition]</a>
|
||||
<li><a href="#lp-host-temporary-files"><code>temporary-files</code> [logical pathname host]</a>
|
||||
</ol>
|
||||
</li>
|
||||
<li><a href="#modifying">Modifying the file system</a>
|
||||
<ol>
|
||||
<li><a href="#copy-file"><code>copy-file</code> [function]</a>
|
||||
<li><a href="#copy-stream"><code>copy-stream</code> [function]</a>
|
||||
<li><a href="#delete-directory-and-files"><code>delete-directory-and-files</code> [function]</a>
|
||||
</ol> </li>
|
||||
<li><a href="#package-path"><code>path</code> [package]</a>
|
||||
</ol>
|
||||
<li><a href="#ack">Acknowledgements</a>
|
||||
</ol>
|
||||
|
||||
|
||||
|
||||
<br> <br><h3><a class=none name="download">Download and installation</a></h3>
|
||||
|
||||
CL-FAD together with this documentation can be downloaded from <a
|
||||
href="https://github.com/edicl/cl-fad/releases/latest">https://github.com/edicl/cl-fad/releases/latest</a>. The
|
||||
current version is 0.7.6.
|
||||
<p>
|
||||
CL-FAD comes with simple system definitions for <a
|
||||
href="http://www.cliki.net/mk-defsystem">MK:DEFSYSTEM</a> and <a
|
||||
href="http://www.cliki.net/asdf">asdf</a> so you can either adapt it
|
||||
to your needs or just unpack the archive and from within the CL-FAD
|
||||
directory start your Lisp image and evaluate the form
|
||||
<code>(mk:compile-system "cl-fad")</code> - or <code>(asdf:oos 'asdf:load-op :cl-fad)</code> for asdf - which should compile and load the whole
|
||||
system.
|
||||
Installation via <a
|
||||
href="http://www.cliki.net/asdf-install">asdf-install</a> should as well
|
||||
be possible. Plus, there are ports
|
||||
for <a href="http://www.gentoo.org/proj/en/common-lisp/index.xml">Gentoo Linux</a> thanks to Matthew Kennedy
|
||||
and for <a href="http://packages.debian.org/cgi-bin/search_packages.pl?keywords=cl-fad&searchon=names&subword=1&version=all&release=all">Debian Linux</a> thanks to René van Bevern.
|
||||
<p>
|
||||
If for some reason you can't or don't want to use MK:DEFSYSTEM or asdf you
|
||||
can just <code>LOAD</code> the file <code>load.lisp</code>.
|
||||
<p>
|
||||
The latest version of the source code lives in the github repository <a href="https://github.com/edicl/cl-fad">edicl/cl-fad</a>.
|
||||
|
||||
If you want to send patches,
|
||||
please <a href="http://weitz.de/patches.html">read this first</a>.
|
||||
Please submit your changes
|
||||
as <a href="https://github.com/edicl/cl-fad/pulls">GitHub pull
|
||||
request"</a>.
|
||||
|
||||
<br> <br><h3><a class=none name="implementations">Supported Lisp implementations</a></h3>
|
||||
|
||||
<p>
|
||||
The following Common Lisp implementations are currently supported:
|
||||
<ul>
|
||||
<li><a href="http://armedbear.org/abcl.html">Armed Bear Common Lisp</a>
|
||||
<li><a href="http://www.cons.org/cmucl/">CMUCL</a>
|
||||
<li><a href="http://www.cormanlisp.com/">Corman Common Lisp</a>
|
||||
<li><a href="http://ecls.sf.net/">ECL</a>
|
||||
<li><a href="http://www.franz.com/products/allegrocl/">Franz AllegroCL</a>
|
||||
<li><a href="http://clisp.cons.org/">GNU CLISP</a>
|
||||
<li><a href="http://www.lispworks.com/">LispWorks</a>
|
||||
<li><a href="http://www.digitool.com/">Macintosh Common Lisp</a>
|
||||
<li><a href="http://openmcl.clozure.com/">OpenMCL</a>
|
||||
<li><a href="http://www.scieneer.com/scl/">Scieneer Common Lisp</a>
|
||||
<li><a href="http://sbcl.sourceforge.net/">Steel Bank Common Lisp</a>
|
||||
</ul>
|
||||
|
||||
I'll gladly accepts patches to make CL-FAD work on other platforms.
|
||||
|
||||
|
||||
<br> <br><h3><a class=none name="dictionary">The CL-FAD dictionary</a></h3>
|
||||
|
||||
<h4><a class=none name="querying">Querying files, directories and pathnames</a></h4>
|
||||
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="directory-exists-p"><b>directory-exists-p</b> <i> pathspec </i> => <i> generalized-boolean</i></a>
|
||||
|
||||
<blockquote><br>
|
||||
Checks whether the file named by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code>
|
||||
exists and if it is a directory. Returns its <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#truename">truename</a> if this is the
|
||||
case, <code>NIL</code> otherwise. The truename is returned in <em>directory form</em> as if
|
||||
by <a href="#pathname-as-directory"><code>PATHNAME-AS-DIRECTORY</code></a>.
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="directory-pathname-p"><b>directory-pathname-p</b> <i> pathspec </i> => <i> generalized-boolean</i></a>
|
||||
|
||||
<blockquote><br>
|
||||
Returns <code>NIL</code> if <code><i>pathspec</i></code> (a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a>) does not designate
|
||||
a directory, <code><i>pathspec</i></code> otherwise. It is irrelevant whether the file or
|
||||
directory designated by <code><i>pathspec</i></code> does actually exist.
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="file-exists-p"><b>file-exists-p</b> <i> pathspec </i> => <i> generalized-boolean</i></a>
|
||||
|
||||
<blockquote><br>
|
||||
Checks whether the file named by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code>
|
||||
exists and returns its <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_t.htm#truename">truename</a> if this is the case, <code>NIL</code> otherwise.
|
||||
The truename is returned in "canonical" form, i.e. the truename of a
|
||||
directory is returned in <em>directory form</em> as if by <a href="#pathname-as-directory"><code>PATHNAME-AS-DIRECTORY</code></a>.
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='pathname-absolute-p'><b>pathname-absolute-p</b> <i>a</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
<p>Returns true if <code><i>a</i></code> is an absolute pathname. This simply
|
||||
tests if <code><i>a</i></code>'s directory list starts with <code>:ABSOLUTE</code></p>
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='pathname-equal'><b>pathname-equal</b> <i>a b</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
|
||||
<p>Returns <em>true</em> if <code><i>a</i></code> and <code><i>b</i></code>
|
||||
represent the same pathname. This function does not access the
|
||||
filesystem, it only looks at the components of the two pathnames to
|
||||
test if they are the same (though by passing both <code><i>a</i></code>
|
||||
and <code><i>b</i></code> to probe-file one can make this function test for
|
||||
file 'sameness'.</p>
|
||||
|
||||
<p>Equality is defined as:</p>
|
||||
|
||||
<ul>
|
||||
<li>strings that are <code>string=</code>
|
||||
<li>symbols (including <code>nil</code> and keywords) which are <code>eql</code>
|
||||
<li>lists of the same length with equal (as per these rules) elements.
|
||||
</ul>
|
||||
|
||||
<p>If any of these tree conditions is false for any of the components in
|
||||
<code><i>a</i></code> and <code><i>b</i></code> then <code><i>a</i></code>
|
||||
and <code><i>b</i></code> are different, otherwise they are the same.</p>
|
||||
|
||||
<p><em>NB:</em> This function does not convert name strings to pathnames. So
|
||||
"foo.txt" and #P"foo.txt" are different pathnames.</p>
|
||||
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='pathname-relative-p'><b>pathname-relative-p</b> <i>a</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
<p>Returns true if <code><i>a</i></code> is a relative pathname. This simply
|
||||
tests if <code><i>a</i></code>'s directory starts
|
||||
with <code>:RELATIVE</code>.</p>
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='pathname-root-p'><b>pathname-root-p</b> <i>a</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
<p>Returns <em>true</em> if <code><i>pathname</i></code> is the root
|
||||
directory (in other words, a directory which is its own parent).</p>
|
||||
</blockquote>
|
||||
|
||||
<h4><a class=none name="manipulating">Manipulating pathnames</a></h4>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='canonical-pathname'><b>canonical-pathname</b> <i>pathname</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
<p>Remove redundant information from PATHNAME.</p>
|
||||
|
||||
<p>This simply walks down <code>PATHNAME</code>'s
|
||||
pathname-directory and drops "." directories, removes :back
|
||||
and its preceding element.</p>
|
||||
|
||||
<p>NB: This function does not access the filesystem, it only looks at the
|
||||
values in the pathname and works on their known (or assumed)
|
||||
meanings.</p>
|
||||
|
||||
<p>NB: Since this function does not access the filesystem it will only
|
||||
remove <code>:BACK</code> elements from the path (not <code>:UP</code>
|
||||
elements). Since some lisps, ccl/sbcl/clisp convert ".." in
|
||||
pathnames to <code>:UP</code>, and not <code>:BACK</code>, the actual
|
||||
utility of the function is limited.</p>
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='merge-pathnames-as-directory'><b>merge-pathnames-as-directory</b> <i><tt>&rest</tt> pathnames</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
<p>Given a list of (probably relative) pathnames, this returns a single
|
||||
directory pathname containing the logical concatenation of them all.</p>
|
||||
|
||||
<p>The returned value is the current directory if one were to cd into
|
||||
each of <code><i>pathnames</i></code> in order. For this reason an
|
||||
absolute pathname will, effectively, cancel the affect of any previous
|
||||
relative pathnames.</p>
|
||||
|
||||
<p>The returned value's defaults are taken from the first element of
|
||||
<code><i>pathnames</i></code> (host, version and device).</p>
|
||||
|
||||
<p><em>NB:</em> Since this function only looks at directory names the name and
|
||||
type of the elements of <code><i>pathnames</i></code> are ignored. Make sure to properly
|
||||
use either trailing #\/s, or <a href="#pathname-as-directory">pathname-as-directory</a>, to get the
|
||||
expected results.</p>
|
||||
|
||||
<p>Examples:</p>
|
||||
|
||||
<pre>
|
||||
(merge-pathnames-as-directory #P"foo/" #P"bar/") == #P"foo/bar/"
|
||||
|
||||
(merge-pathnames-as-directory #P"foo/" #P"./bar/") == #P"foo/./bar/"
|
||||
|
||||
(merge-pathnames-as-directory #P"foo/" #P"/bar/") == #P"/bar/"
|
||||
|
||||
(merge-pathnames-as-directory #P"foo/" #P"/bar/" #P'quux/file.txt) == #P"/bar/quux/"
|
||||
</pre>
|
||||
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='merge-pathnames-as-file'><b>merge-pathnames-as-file</b> <i><tt>&rest</tt> pathnames</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
<p>Given a list of, probably relative, pathnames returns a single
|
||||
filename pathname containing the logical concatenation of them all.</p>
|
||||
|
||||
<p>The returned value's defaults are taken from the first element of
|
||||
<code><i>pathnames</i></code> (host, version and device). The returned
|
||||
values's name, type and version are taken from the last element
|
||||
of <code><i>pathnames</i></code>. The intervening elements are used only for
|
||||
their pathname-directory values.</p>
|
||||
|
||||
Examples:
|
||||
|
||||
<pre>
|
||||
(merge-pathnames-as-file #P"foo/" #P"bar.txt") == #P"foo/bar.txt"
|
||||
|
||||
(merge-pathnames-as-file #P"foo/" #P"./bar.txt") == #P"foo/./bar.txt"
|
||||
|
||||
(merge-pathnames-as-file #P"foo/" #P"/bar/README") == #P"/bar/README"
|
||||
|
||||
(merge-pathnames-as-file #P"/foo/" #P"/bar/" #P'quux/file.txt) == #P"/bar/quux/file.txt"
|
||||
</pre>
|
||||
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="pathname-as-directory"><b>pathname-as-directory</b> <i> pathspec </i> => <i> pathname</i></a>
|
||||
<blockquote><br>
|
||||
Converts the <em>non-wild</em> <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code> to <em>directory form</em>, i.e. it returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname">pathname</a> which would return a <em>true</em> value if fed to <a href="#directory-pathname-p"><code>DIRECTORY-PATHNAME-P</code></a>.
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="pathname-as-file"><b>pathname-as-file</b> <i> pathspec </i> => <i> pathname</i></a>
|
||||
|
||||
<blockquote><br>
|
||||
Converts the <em>non-wild</em> <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>pathspec</i></code> to <em>file form</em>, i.e. it returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname">pathname</a> which would return a <code>NIL</code> value if fed to <a href="#directory-pathname-p"><code>DIRECTORY-PATHNAME-P</code></a>.
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='pathname-directory-pathname'><b>pathname-directory-pathname</b> <i>pathname</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
<p>Returns a complete pathname representing the directory of
|
||||
<code><i>pathname</i></code>. If <code><i>pathname</i></code> is
|
||||
already a directory pathname
|
||||
(<code>name</code> <code>nil</code>, <code>type</code>
|
||||
<code>nil</code>) returns a pathname equal (as
|
||||
per <a href="#pathname-equal">pathname-equal</a>) to it.</p>
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]<br><a class=none name='pathname-parent-directory'><b>pathname-parent-directory</b> <i>pathname</i> => <i>result</i></a>
|
||||
<blockquote>
|
||||
|
||||
<p>Returns a pathname which would, by name at least,
|
||||
contain <code><i>pathname</i></code> as one of its direct
|
||||
children. Symlinks can make the parent/child relationship a like
|
||||
opaque, but generally speaking the value returned by this function is
|
||||
a directory name which contains <code><i>pathname</i></code>.</p>
|
||||
|
||||
<p>The root directory, #P"/", is its own parent. The parent
|
||||
directory of a filename is the parent of the filename's
|
||||
dirname.</p>
|
||||
|
||||
</blockquote>
|
||||
|
||||
<h4><a class=none name="traversing">Traversing directories</a></h4>
|
||||
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="list-directory"><b>list-directory</b> <i> dirname <tt>&key</tt> follow-symlinks</i> => <i> list</i></a>
|
||||
|
||||
<blockquote><br>
|
||||
<p>
|
||||
Returns a <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#fresh">fresh</a> list of pathnames corresponding to
|
||||
all files within the directory named by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>dirname</i></code>. The pathnames of sub-directories are returned in
|
||||
<em>directory form</em> - see <a href="#pathname-as-directory"><code>PATHNAME-AS-DIRECTORY</code></a>.
|
||||
</p>
|
||||
<p>
|
||||
If <code><i>follow-symlinks</i></code> is true (which is the
|
||||
default), then the returned list contains truenames (symlinks will
|
||||
be resolved) which essentially means that it might also return files
|
||||
from <b>outside</b> the directory. This works on all platforms.
|
||||
</p>
|
||||
<p>
|
||||
When <code><i>follow-symlinks</i></code> is <code>NIL</code>, it should return the actual directory
|
||||
contents, which might include symlinks. (This is currently implemented only on SBCL and CCL.)
|
||||
</p>
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="walk-directory"><b>walk-directory</b> <i> dirname fn <tt>&key</tt> directories if-does-not-exist test follow-symlinks</i> => |</a>
|
||||
|
||||
<blockquote><br>
|
||||
<p>
|
||||
Recursively applies the function designated by the <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_f.htm#function_designator">function
|
||||
designator</a> <code><i>fn</i></code> to all files within the directory named
|
||||
by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname
|
||||
designator</a> <code><i>dirname</i></code> and all of its sub-directories. <code><i>fn</i></code>
|
||||
will only be applied to files for which the function <code><i>test</i></code>
|
||||
returns a <em>true</em> value. (The default value for <code><i>test</i></code>
|
||||
always returns <em>true</em>.) If <code><i>directories</i></code> is not <code>NIL</code>,
|
||||
<code><i>fn</i></code> and <code><i>test</i></code> are applied to directories
|
||||
as well. If <code><i>directories</i></code> is <code>:DEPTH-FIRST</code>, <code><i>fn</i></code>
|
||||
will be applied to the directory's contents first. If <code><i>directories</i></code>
|
||||
is <code>:BREADTH-FIRST</code> and <code><i>test</i></code> returns <code>NIL</code>, the
|
||||
directory's content will be skipped. <code><i>if-does-not-exist</i></code> must
|
||||
be one of <code>:ERROR</code> or <code>:IGNORE</code> where <code>:ERROR</code>
|
||||
(the default) means that an error will be signaled if the directory <code><i>dirname</i></code>
|
||||
does not exist.
|
||||
</p>
|
||||
<p>
|
||||
If <code><i>follow-symlinks</i></code> is true (which is
|
||||
the default), then your callback will receive truenames. Otherwise
|
||||
you should get the actual directory contents, which might include
|
||||
symlinks. This might not be supported on all platforms. See
|
||||
<a href="#list-directory"><code>LIST-DIRECTORY</code></a>.
|
||||
</p>
|
||||
</blockquote>
|
||||
|
||||
<h4><a class=none name="temporary-files">Temporary Files</a></h4>
|
||||
|
||||
<h5>Synopsis</h5>
|
||||
|
||||
<p>
|
||||
Create a temporary file and return its name:
|
||||
<pre>CL-USER> (temporary-file:<code xmlns=""><a href="#with-output-to-temporary-file">with-output-to-temporary-file</a></code> (foo)
|
||||
(print "hello" foo))
|
||||
#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/temp-yjck024x"</pre>
|
||||
</p>
|
||||
<p>
|
||||
Create a temporary file, read and write it, have it be deleted
|
||||
automatically:
|
||||
<pre>CL-USER> (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :direction :io)
|
||||
(print "hello" foo)
|
||||
(file-position foo 0)
|
||||
(read foo))
|
||||
"hello"</pre>
|
||||
</p>
|
||||
|
||||
<h5><a class="none" name="default-temporary-directory">Default temporary file directory</a></h5>
|
||||
By default, temporary files are created in a system specific
|
||||
directory that defaults based on operating system conventions. On
|
||||
Unix and Unix-like systems, the directory <tt>/tmp/</tt> is used
|
||||
by default. It can be overridden by setting the <tt>TMPDIR</tt>
|
||||
environment variable. On Windows, the value of the environment
|
||||
variable <tt>TEMP</tt> is used. If it is not set, temporary file
|
||||
creation will fail.
|
||||
|
||||
<h5><a class="none" name="defining-temporary-directory">Defining the temporary file directory</a></h5>
|
||||
<p>
|
||||
The Lisp application can set the default directory in which
|
||||
temporary files are created by the way of the
|
||||
<code xmlns=""><a href="#temporary-files">temporary-files</a></code> logical pathname host:
|
||||
|
||||
<pre>(setf (<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_logica.htm">logical-pathname-translations</a> "<code xmlns=""><a href="#temporary-files">temporary-files</a></code>") '(("*.*.*" "/var/tmp/")))</pre>
|
||||
|
||||
This would set the directory for temporary files to
|
||||
<tt>/var/tmp/</tt>. For more information about logical
|
||||
pathnames, please refer to <a href="http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/html/cltl/clm/node208.html#SECTION002715000000000000000">Common
|
||||
Lisp the Language, 2nd Edition</a> and the <a href="http://clhs.lisp.se/Body/19_.htm">Common Lisp
|
||||
HyperSpec</a>.
|
||||
</p>
|
||||
<p>
|
||||
Physical path names have restrictions regarding the permitted
|
||||
character in file names. If these restrictions conflict with
|
||||
your desired naming scheme, you can pass a physical pathname as
|
||||
TEMPLATE parameter to the temporary file generation function.
|
||||
</p>
|
||||
<p>
|
||||
Here are a few examples:
|
||||
<pre>CL-USER> (<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_logica.htm">logical-pathname-translations</a> "temporary-files")
|
||||
(("*.*.*" #P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/"))
|
||||
CL-USER> (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo)
|
||||
(<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
|
||||
#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/temp-6rdqdkd1"</pre>
|
||||
|
||||
This used the temporary directory established in the TMPDIR
|
||||
environment variable, by the way of the definition of the
|
||||
temporary-files logical host definition.
|
||||
|
||||
<pre>CL-USER> (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :template "/tmp/file.with.dots.in.name.%.txt")
|
||||
(<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
|
||||
#P"/tmp/file.with.dots.in.name.2EF04KUJ.txt"</pre>
|
||||
|
||||
Here, a physical pathname was used for the
|
||||
<code xmlns=""><i>:template</i></code> keyword argument so that a
|
||||
filename containing multiple dots could be generated.
|
||||
|
||||
<pre>CL-USER> (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :template "temporary-files:blah-%.txt")
|
||||
(<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
|
||||
#P"/var/folders/Yu/YuNMNBNPGoqs9G-1Wmj1dk+++TI/-Tmp-/blah-72mj450d.txt"</pre>
|
||||
|
||||
This used the temporary-files logical pathname host, but changed
|
||||
the filename slightly.
|
||||
|
||||
<pre>CL-USER> *default-pathname-defaults*
|
||||
#P"/Users/hans/"
|
||||
CL-USER> (temporary-file:<code xmlns=""><a href="#with-open-temporary-file">with-open-temporary-file</a></code> (foo :template "blah-%.txt")
|
||||
(<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a> foo))
|
||||
#P"/Users/hans/blah-5OEJELG2.txt"</pre>
|
||||
|
||||
Here, a relative pathname was used in the template, which
|
||||
caused the file to be generated in the directory established
|
||||
by <a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/v_defaul.htm">*default-pathname-defaults*</a>.
|
||||
</p>
|
||||
<p>
|
||||
Alternatively, the <code xmlns=""><a href="#*default-template*">*default-template*</a></code>
|
||||
special variable can be set to define a custom default template
|
||||
for generating names.
|
||||
</p>
|
||||
|
||||
<h5 xmlns=""><a class="none" name="security">Security</a></h5>
|
||||
The TEMPORARY-FILE library does not directly address security
|
||||
issues. The application that uses it needs to take additional
|
||||
measures if it is important that files created by one process
|
||||
cannot be accessed by other, unrelated processes. This can be
|
||||
done by using the system dependent security mechanisms like
|
||||
default file permissions or access control lists.
|
||||
|
||||
<h5>Dictionary</h5>
|
||||
|
||||
|
||||
<p xmlns="">[Function]<br><a class="none" name="open-temporary"><b>open-temporary</b> <i><clix:lambda-list xmlns:clix="http://bknr.net/clixdoc"><tt>&rest</tt> open-arguments <tt>&key</tt> template generate-random-string max-tries <tt>&allow-other-keys</tt></clix:lambda-list></i>
|
||||
=>
|
||||
<i>stream</i></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
<p xmlns="http://www.w3.org/1999/xhtml">
|
||||
Create a file with a randomly generated name and return the
|
||||
opened stream. The resulting pathname is generated from
|
||||
<code xmlns=""><i>template</i></code>, which is a string
|
||||
representing a pathname template. A percent sign (%) in
|
||||
that string is replaced by a randomly generated string to
|
||||
make the filename unique. The default for
|
||||
<code xmlns=""><i>template</i></code> places temporary files in the
|
||||
<code xmlns=""><a href="#temporary-files">temporary-files</a></code> logical pathname host,
|
||||
which is automatically set up in a system specific manner.
|
||||
The file name generated from <code xmlns=""><i>template</i></code>
|
||||
is merged with <a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/v_defaul.htm">*default-pathname-defaults*</a>,
|
||||
so random pathnames relative to that directory can be
|
||||
generated by not specifying a directory in
|
||||
<code xmlns=""><i>template</i></code>.
|
||||
</p>
|
||||
<p xmlns="http://www.w3.org/1999/xhtml">
|
||||
<code xmlns=""><i>generate-random-string</i></code> can be passed to
|
||||
override the default function that generates the random name
|
||||
component. It should return a random string consisting of
|
||||
characters that are permitted in a pathname (logical or
|
||||
physical, depending on <code xmlns=""><i>template</i></code>).
|
||||
</p>
|
||||
<p xmlns="http://www.w3.org/1999/xhtml">
|
||||
The name of the temporary file can be accessed calling the
|
||||
<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_pn.htm">pathname</a>
|
||||
function on <code xmlns=""><i>stream</i></code>. For convenience,
|
||||
the temporary file is opened on the physical pathname,
|
||||
i.e. if the <code xmlns=""><i>template</i></code> designate a
|
||||
logical pathname the translation to a physical pathname is
|
||||
performed before opening the stream.
|
||||
</p>
|
||||
<p xmlns="http://www.w3.org/1999/xhtml">
|
||||
In order to create a unique file name,
|
||||
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> may loop internally up
|
||||
to <code xmlns=""><i>max-tries</i></code> times before giving up and
|
||||
signalling a
|
||||
<code xmlns=""><a href="#cannot-create-temporary-file">cannot-create-temporary-file</a></code> condition.
|
||||
</p>
|
||||
<p xmlns="http://www.w3.org/1999/xhtml">
|
||||
Any unrecognized keyword arguments are passed to the call to
|
||||
<a xmlns="" href="http://www.lispworks.com/documentation/HyperSpec/Body/f_open.htm">open</a>.
|
||||
</p>
|
||||
</clix:description></blockquote></p>
|
||||
<p xmlns="">[Macro]<br><a class="none" name="with-output-to-temporary-file"><b>with-output-to-temporary-file</b> <i><clix:lambda-list xmlns:clix="http://bknr.net/clixdoc">(stream <tt>&rest</tt> args) <tt>&body</tt> body</clix:lambda-list></i>
|
||||
=>
|
||||
<i>pathname</i></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
Create a temporary file using
|
||||
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> with
|
||||
<code xmlns=""><i>args</i></code> and run <code xmlns=""><i>body</i></code>
|
||||
with <code xmlns=""><i>stream</i></code> bound to the temporary file
|
||||
stream. Returns the pathname of the file that has been
|
||||
created. See <code xmlns=""><a href="#open-temporary">open-temporary</a></code> for
|
||||
permitted options.
|
||||
</clix:description></blockquote></p>
|
||||
<p xmlns="">[Macro]<br><a class="none" name="with-open-temporary-file"><b>with-open-temporary-file</b> <i><clix:lambda-list xmlns:clix="http://bknr.net/clixdoc">(stream <tt>&rest</tt> args <tt>&key</tt> keep <tt>&allow-other-keys</tt>) <tt>&body</tt> body</clix:lambda-list></i>
|
||||
=>
|
||||
<i>values</i></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
Create a temporary file using
|
||||
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> with
|
||||
<code xmlns=""><i>args</i></code> and run <code xmlns=""><i>body</i></code>
|
||||
with <code xmlns=""><i>stream</i></code> bound to the temporary file
|
||||
stream. Returns the values returned by
|
||||
<code xmlns=""><i>body</i></code>. By default, the file is deleted
|
||||
when <code xmlns=""><i>body</i></code> is exited. If a true value is
|
||||
passed in <code xmlns=""><i>keep</i></code>, the file is not deleted
|
||||
when the body is exited. See
|
||||
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> for more permitted
|
||||
options.
|
||||
</clix:description></blockquote></p>
|
||||
<p xmlns="">
|
||||
[Special variable]<br><a class="none" name="*default-template*"><b>*default-template*</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
This variable can be set to a string representing the desired
|
||||
default template for temporary file name generation. See
|
||||
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> for a description of the
|
||||
template string format.
|
||||
</clix:description></blockquote></p>
|
||||
<p xmlns="">
|
||||
[Condition type]<br><a class="none" name="cannot-create-temporary-file"><b>cannot-create-temporary-file</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
Signalled when an attempt to create unique temporary file name
|
||||
failed after the established number of retries.
|
||||
</clix:description></blockquote></p>
|
||||
<p xmlns="">
|
||||
[Condition type]<br><a class="none" name="invalid-temporary-pathname-template"><b>invalid-temporary-pathname-template</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
Signalled when the <code xmlns=""><i>template</i></code> argument to
|
||||
<code xmlns=""><a href="#open-temporary">open-temporary</a></code> does not contain a valid
|
||||
template string. The template string must contain a percent
|
||||
sign, which is replaced by the generated random string to
|
||||
yield the filename.
|
||||
</clix:description></blockquote></p>
|
||||
<p xmlns="">
|
||||
[Condition type]<br><a class="none" name="missing-temp-environment-variable"><b>missing-temp-environment-variable</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
(Windows only) Signalled when the TEMP environment variable is
|
||||
not set.
|
||||
</clix:description></blockquote></p>
|
||||
<p xmlns="">
|
||||
[Logical Pathname Host]<br><a class="none" name="lp-host-temporary-files"><b>temporary-files</b></a><blockquote><clix:description xmlns:clix="http://bknr.net/clixdoc">
|
||||
This logical pathname host defines where temporary files are
|
||||
stored by default. It is initialized in a suitable system
|
||||
specific fashion: On Unix and Unix-like systems, the directory
|
||||
specified in the TMPDIR environment variable is used. If that
|
||||
variable is not set, /tmp is used as the default. On Windows,
|
||||
the directory specified in the TEMP environment variable is
|
||||
used. If it is not set, a
|
||||
<code xmlns=""><a href="#missing-temp-environment-variable">missing-temp-environment-variable</a></code> error
|
||||
is signalled.
|
||||
</clix:description></blockquote></p>
|
||||
|
||||
|
||||
<h4><a class=none name="modifying">Modifying the file system</a></h4>
|
||||
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="copy-file"><b>copy-file</b> <i> from to <tt>&key</tt> overwrite</i> => |</a>
|
||||
|
||||
<blockquote><br>
|
||||
Copies the file designated by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>from</i></code> to the
|
||||
file designated by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>to</i></code>. If <code><i>overwrite</i></code> is <em>true</em> (the default is <code>NIL</code>)
|
||||
overwrites the file designated by <code><i>to</i></code> if it exists.
|
||||
</blockquote>
|
||||
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="copy-stream"><b>copy-stream</b> <i> from to <tt>&optional</tt> checkp</i> => |</a>
|
||||
|
||||
<blockquote><br> Copies into <code><i>to</i></code> (a stream)
|
||||
from <code><i>from</i></code> (also a stream) until the end
|
||||
of <code><i>from</i></code> is reached. The streams should have the
|
||||
same <a
|
||||
href="http://www.lispworks.com/documentation/HyperSpec/Body/f_stm_el.htm">element
|
||||
type</a> unless they are bivalent. If <code><i>checkp</i></code> is
|
||||
true (which is the default), the function will signal an error if the
|
||||
element types aren't the same.
|
||||
</blockquote>
|
||||
<p><br>[Function]
|
||||
<br><a class=none name="delete-directory-and-files"><b>delete-directory-and-files</b> <i> dirname <tt>&key</tt> if-does-not-exist</i> => |</a>
|
||||
|
||||
<blockquote><br>
|
||||
<p>
|
||||
Recursively deletes all files and directories within the directory
|
||||
designated by the non-wild <a href="http://www.lispworks.com/documentation/HyperSpec/Body/26_glo_p.htm#pathname_designator">pathname designator</a> <code><i>dirname</i></code> including
|
||||
<code><i>dirname</i></code> itself. <code><i>if-does-not-exist</i></code> must be one of <code>:ERROR</code> or <code>:IGNORE</code>
|
||||
where <code>:ERROR</code> (the default) means that an error will be signaled if the directory
|
||||
<code><i>dirname</i></code> does not exist.
|
||||
</p>
|
||||
<p>
|
||||
<b>Warning:</b> this function <em>might</em> remove files from outside the
|
||||
directory, if the directory that you are deleting contains links to
|
||||
external files. This is currently fixed for SBCL and CCL.
|
||||
</p>
|
||||
</blockquote>
|
||||
|
||||
<h4>The <code>PATH</code> package</h4>
|
||||
|
||||
<p><br>[Package]
|
||||
<br><a class=none name="package-path">(defpackage <b>path</b>)</a>
|
||||
|
||||
<blockquote>
|
||||
Provides a set of short names for commonly used pathname manipulation
|
||||
functions (these are all functions from the <code>cl-fad</code>
|
||||
package which are being exported under different names):
|
||||
<dl>
|
||||
<dt><code>dirname</code></dt> <dd><a href="#pathname-as-directory">pathname-as-directory</a></dd>
|
||||
<dt><code>basename</code></dt> <dd><code>cl:file-namestring</code></dd>
|
||||
<dt><code>-e</code></dt> <dd><a href="#file-exists-p">file-exists-p</a></dd>
|
||||
<dt><code>-d</code></dt> <dd><a href="#directory-exists-p">directory-exists-p</a></dd>
|
||||
<dt><code>catfile</code></dt> <dd><a href="#merge-pathnames-as-file">merge-pathnames-as-file</a></dd>
|
||||
<dt><code>catdir</code></dt> <dd><a href="#merge-pathnames-as-directory">merge-pathnames-as-directory</a></dd>
|
||||
<dt><code>rm-r</code></dt> <dd><a href="#delete-directory-and-files">delete-directory-and-files</a></dd>
|
||||
<dt><code>=</code></dt> <dd><a href="#pathname-equal">pathname-equal</a></dd>
|
||||
<dt><code>absolute-p</code></dt> <dd><a href="#pathname-absolute-p">pathname-absolute-p</a></dd>
|
||||
<dt><code>relative-p</code></dt> <dd><a href="#pathname-relative-p">pathname-relative-p</a></dd>
|
||||
<dt><code>root-p</code></dt> <dd><a href="#pathname-root-p">pathname-root-p</a></dd>
|
||||
</dl>
|
||||
</blockquote>
|
||||
|
||||
|
||||
<br> <br><h3><a class=none name="ack">Acknowledgements</a></h3>
|
||||
|
||||
The original code for this library was written by Peter Seibel for his
|
||||
book <a href="http://www.gigamonkeys.com/book/"><em>Practical Common
|
||||
Lisp</em></a>. I added some stuff and made sure it worked properly on
|
||||
Windows, specifically with CCL. Thanks to James Bielman, Maciek
|
||||
Pasternacki, Jack D. Unrue, Gary King, and Douglas Crosher who sent
|
||||
patches for OpenMCL, ECL, ABCL, MCL, and Scieneer CL.
|
||||
|
||||
<p>
|
||||
$Header: /usr/local/cvsrep/cl-fad/doc/index.html,v 1.33 2009/09/30 14:23:12 edi Exp $
|
||||
<p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a>
|
||||
|
||||
</body>
|
||||
</html>
|
||||
|
||||
|
|
@ -0,0 +1,570 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-FAD; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/cl-fad/fad.lisp,v 1.35 2009/09/30 14:23:10 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2004, Peter Seibel. All rights reserved.
|
||||
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
|
||||
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
|
||||
;;; * Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
|
||||
;;; * Redistributions in binary form must reproduce the above
|
||||
;;; copyright notice, this list of conditions and the following
|
||||
;;; disclaimer in the documentation and/or other materials
|
||||
;;; provided with the distribution.
|
||||
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS 'AS IS' AND ANY EXPRESSED
|
||||
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
||||
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
||||
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
||||
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
||||
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
(in-package :cl-fad)
|
||||
|
||||
(defun component-present-p (value)
|
||||
"Helper function for DIRECTORY-PATHNAME-P which checks whether VALUE
|
||||
is neither NIL nor the keyword :UNSPECIFIC."
|
||||
(and value (not (eql value :unspecific))))
|
||||
|
||||
(defun directory-pathname-p (pathspec)
|
||||
"Returns NIL if PATHSPEC \(a pathname designator) does not designate
|
||||
a directory, PATHSPEC otherwise. It is irrelevant whether file or
|
||||
directory designated by PATHSPEC does actually exist."
|
||||
(and
|
||||
(not (component-present-p (pathname-name pathspec)))
|
||||
(not (component-present-p (pathname-type pathspec)))
|
||||
pathspec))
|
||||
|
||||
(defun pathname-as-directory (pathspec)
|
||||
"Converts the non-wild pathname designator PATHSPEC to directory
|
||||
form."
|
||||
(let ((pathname (pathname pathspec)))
|
||||
(when (wild-pathname-p pathname)
|
||||
(error "Can't reliably convert wild pathnames."))
|
||||
(cond ((not (directory-pathname-p pathspec))
|
||||
(make-pathname :directory (append (or (pathname-directory pathname)
|
||||
(list :relative))
|
||||
(list (file-namestring pathname)))
|
||||
:name nil
|
||||
:type nil
|
||||
:defaults pathname))
|
||||
(t pathname))))
|
||||
|
||||
(defun directory-wildcard (dirname)
|
||||
"Returns a wild pathname designator that designates all files within
|
||||
the directory named by the non-wild pathname designator DIRNAME."
|
||||
(when (wild-pathname-p dirname)
|
||||
(error "Can only make wildcard directories from non-wildcard directories."))
|
||||
(make-pathname :name #-:cormanlisp :wild #+:cormanlisp "*"
|
||||
:type #-(or :clisp :cormanlisp) :wild
|
||||
#+:clisp nil
|
||||
#+:cormanlisp "*"
|
||||
:defaults (pathname-as-directory dirname)))
|
||||
|
||||
#+:clisp
|
||||
(defun clisp-subdirectories-wildcard (wildcard)
|
||||
"Creates a wild pathname specifically for CLISP such that
|
||||
sub-directories are returned by DIRECTORY."
|
||||
(make-pathname :directory (append (pathname-directory wildcard)
|
||||
(list :wild))
|
||||
:name nil
|
||||
:type nil
|
||||
:defaults wildcard))
|
||||
|
||||
(defun list-directory (dirname &key (follow-symlinks t))
|
||||
"Returns a fresh list of pathnames corresponding to all files within
|
||||
the directory named by the non-wild pathname designator DIRNAME.
|
||||
The pathnames of sub-directories are returned in directory form -
|
||||
see PATHNAME-AS-DIRECTORY.
|
||||
|
||||
If FOLLOW-SYMLINKS is true, then the returned list contains
|
||||
truenames (symlinks will be resolved) which essentially means that it
|
||||
might also return files from *outside* the directory. This works on
|
||||
all platforms.
|
||||
|
||||
When FOLLOW-SYMLINKS is NIL, it should return the actual directory
|
||||
contents, which might include symlinks. Currently this works on SBCL
|
||||
and CCL."
|
||||
(declare (ignorable follow-symlinks))
|
||||
(when (wild-pathname-p dirname)
|
||||
(error "Can only list concrete directory names."))
|
||||
#+(or :ecl :clasp)
|
||||
(let ((dir (pathname-as-directory dirname)))
|
||||
(concatenate 'list
|
||||
(directory (merge-pathnames (pathname "*/") dir))
|
||||
(directory (merge-pathnames (pathname "*.*") dir))))
|
||||
#-(or :ecl :clasp)
|
||||
(let ((wildcard (directory-wildcard dirname)))
|
||||
#+:abcl (system::list-directory dirname)
|
||||
#+:sbcl (directory wildcard :resolve-symlinks follow-symlinks)
|
||||
#+(or :cmu :scl :lispworks) (directory wildcard)
|
||||
#+(or :openmcl :digitool) (directory wildcard :directories t :follow-links follow-symlinks)
|
||||
#+:allegro (directory wildcard :directories-are-files nil)
|
||||
#+:clisp (nconc (directory wildcard :if-does-not-exist :keep)
|
||||
(directory (clisp-subdirectories-wildcard wildcard)))
|
||||
#+:cormanlisp (nconc (directory wildcard)
|
||||
(cl::directory-subdirs dirname)))
|
||||
#-(or :sbcl :cmu :scl :lispworks :openmcl :allegro :clisp :cormanlisp :ecl :abcl :digitool :clasp)
|
||||
(error "LIST-DIRECTORY not implemented"))
|
||||
|
||||
(defun pathname-as-file (pathspec)
|
||||
"Converts the non-wild pathname designator PATHSPEC to file form."
|
||||
(let ((pathname (pathname pathspec)))
|
||||
(when (wild-pathname-p pathname)
|
||||
(error "Can't reliably convert wild pathnames."))
|
||||
(cond ((directory-pathname-p pathspec)
|
||||
(let* ((directory (pathname-directory pathname))
|
||||
(name-and-type (pathname (first (last directory)))))
|
||||
(make-pathname :directory (butlast directory)
|
||||
:name (pathname-name name-and-type)
|
||||
:type (pathname-type name-and-type)
|
||||
:defaults pathname)))
|
||||
(t pathname))))
|
||||
|
||||
(defun file-exists-p (pathspec)
|
||||
"Checks whether the file named by the pathname designator PATHSPEC
|
||||
exists and returns its truename if this is the case, NIL otherwise.
|
||||
The truename is returned in `canonical' form, i.e. the truename of a
|
||||
directory is returned as if by PATHNAME-AS-DIRECTORY."
|
||||
#+(or :sbcl :lispworks :openmcl :ecl :digitool clasp) (probe-file pathspec)
|
||||
#+:allegro (or (excl:probe-directory (pathname-as-directory pathspec))
|
||||
(probe-file pathspec))
|
||||
#+(or :cmu :scl :abcl) (or (probe-file (pathname-as-directory pathspec))
|
||||
(probe-file pathspec))
|
||||
#+:cormanlisp (or (and (ccl:directory-p pathspec)
|
||||
(pathname-as-directory pathspec))
|
||||
(probe-file pathspec))
|
||||
#+:clisp (or (ignore-errors
|
||||
(let ((directory-form (pathname-as-directory pathspec)))
|
||||
(when (ext:probe-directory directory-form)
|
||||
(truename directory-form))))
|
||||
(ignore-errors
|
||||
(probe-file (pathname-as-file pathspec))))
|
||||
#-(or :sbcl :cmu :scl :lispworks :openmcl :allegro :clisp :cormanlisp :ecl :abcl :digitool :clasp)
|
||||
(error "FILE-EXISTS-P not implemented"))
|
||||
|
||||
(defun directory-exists-p (pathspec)
|
||||
"Checks whether the file named by the pathname designator PATHSPEC
|
||||
exists and if it is a directory. Returns its truename if this is the
|
||||
case, NIL otherwise. The truename is returned in directory form as if
|
||||
by PATHNAME-AS-DIRECTORY."
|
||||
#+:allegro
|
||||
(and (excl:probe-directory pathspec)
|
||||
(pathname-as-directory (truename pathspec)))
|
||||
#+:lispworks
|
||||
(and (lw:file-directory-p pathspec)
|
||||
(pathname-as-directory (truename pathspec)))
|
||||
#-(or :allegro :lispworks)
|
||||
(let ((result (file-exists-p pathspec)))
|
||||
(and result
|
||||
(directory-pathname-p result)
|
||||
result)))
|
||||
|
||||
(defun walk-directory (dirname fn &key directories
|
||||
(if-does-not-exist :error)
|
||||
(test (constantly t))
|
||||
(follow-symlinks t))
|
||||
"Recursively applies the function FN to all files within the
|
||||
directory named by the non-wild pathname designator DIRNAME and all of
|
||||
its sub-directories. FN will only be applied to files for which the
|
||||
function TEST returns a true value. If DIRECTORIES is not NIL, FN and
|
||||
TEST are applied to directories as well. If DIRECTORIES
|
||||
is :DEPTH-FIRST, FN will be applied to the directory's contents first.
|
||||
If DIRECTORIES is :BREADTH-FIRST and TEST returns NIL, the directory's
|
||||
content will be skipped. IF-DOES-NOT-EXIST must be one of :ERROR
|
||||
or :IGNORE where :ERROR means that an error will be signaled if the
|
||||
directory DIRNAME does not exist. If FOLLOW-SYMLINKS is T, then your
|
||||
callback will receive truenames. Otherwise you should get the actual
|
||||
directory contents, which might include symlinks. This might not be
|
||||
supported on all platforms. See LIST-DIRECTORY."
|
||||
(labels ((walk (name)
|
||||
(cond
|
||||
((directory-pathname-p name)
|
||||
;; the code is written in a slightly awkward way for
|
||||
;; backward compatibility
|
||||
(cond ((not directories)
|
||||
(dolist (file (list-directory name :follow-symlinks follow-symlinks))
|
||||
(walk file)))
|
||||
((eql directories :breadth-first)
|
||||
(when (funcall test name)
|
||||
(funcall fn name)
|
||||
(dolist (file (list-directory name :follow-symlinks follow-symlinks))
|
||||
(walk file))))
|
||||
;; :DEPTH-FIRST is implicit
|
||||
(t (dolist (file (list-directory name :follow-symlinks follow-symlinks))
|
||||
(walk file))
|
||||
(when (funcall test name)
|
||||
(funcall fn name)))))
|
||||
((funcall test name)
|
||||
(funcall fn name)))))
|
||||
(let ((pathname-as-directory (pathname-as-directory dirname)))
|
||||
(case if-does-not-exist
|
||||
((:error)
|
||||
(cond ((not (file-exists-p pathname-as-directory))
|
||||
(error "File ~S does not exist."
|
||||
pathname-as-directory))
|
||||
(t (walk pathname-as-directory))))
|
||||
((:ignore)
|
||||
(when (file-exists-p pathname-as-directory)
|
||||
(walk pathname-as-directory)))
|
||||
(otherwise
|
||||
(error "IF-DOES-NOT-EXIST must be one of :ERROR or :IGNORE."))))
|
||||
(values)))
|
||||
|
||||
(defvar *stream-buffer-size* 8192)
|
||||
|
||||
(defun copy-stream (from to &optional (checkp t))
|
||||
"Copies into TO \(a stream) from FROM \(also a stream) until the end
|
||||
of FROM is reached, in blocks of *stream-buffer-size*. The streams
|
||||
should have the same element type. If CHECKP is true, the streams are
|
||||
checked for compatibility of their types."
|
||||
(when checkp
|
||||
(unless (subtypep (stream-element-type to) (stream-element-type from))
|
||||
(error "Incompatible streams ~A and ~A." from to)))
|
||||
(let ((buf (make-array *stream-buffer-size*
|
||||
:element-type (stream-element-type from))))
|
||||
(loop
|
||||
(let ((pos #-:clisp (read-sequence buf from)
|
||||
#+:clisp (ext:read-byte-sequence buf from :no-hang nil)))
|
||||
(when (zerop pos) (return))
|
||||
(write-sequence buf to :end pos))))
|
||||
(values))
|
||||
|
||||
(defun copy-file (from to &key overwrite)
|
||||
"Copies the file designated by the non-wild pathname designator FROM
|
||||
to the file designated by the non-wild pathname designator TO. If
|
||||
OVERWRITE is true overwrites the file designated by TO if it exists."
|
||||
#+:allegro (excl.osi:copy-file from to :overwrite overwrite)
|
||||
#-:allegro
|
||||
(let ((element-type #-:cormanlisp '(unsigned-byte 8)
|
||||
#+:cormanlisp 'unsigned-byte))
|
||||
(with-open-file (in from :element-type element-type)
|
||||
(with-open-file (out to :element-type element-type
|
||||
:direction :output
|
||||
:if-exists (if overwrite
|
||||
:supersede
|
||||
#-:cormanlisp :error
|
||||
#+:cormanlisp nil))
|
||||
#+:cormanlisp
|
||||
(unless out
|
||||
(error (make-condition 'file-error
|
||||
:pathname to
|
||||
:format-control "File already exists.")))
|
||||
(copy-stream in out))))
|
||||
(values))
|
||||
|
||||
(defun delete-directory-and-files (dirname &key (if-does-not-exist :error))
|
||||
"Recursively deletes all files and directories within the directory
|
||||
designated by the non-wild pathname designator DIRNAME including
|
||||
DIRNAME itself. IF-DOES-NOT-EXIST must be one of :ERROR or :IGNORE
|
||||
where :ERROR means that an error will be signaled if the directory
|
||||
DIRNAME does not exist.
|
||||
|
||||
NOTE: this function is dangerous if the directory that you are
|
||||
removing contains symlinks to files outside of it - the target files
|
||||
might be removed instead! This is currently fixed for SBCL and CCL."
|
||||
|
||||
#+:allegro (excl.osi:delete-directory-and-files dirname
|
||||
:if-does-not-exist if-does-not-exist)
|
||||
|
||||
#+:sbcl
|
||||
(if (directory-exists-p dirname)
|
||||
(sb-ext:delete-directory dirname :recursive t)
|
||||
(ecase if-does-not-exist
|
||||
(:error (error "~S is not a directory" dirname))
|
||||
(:ignore nil)))
|
||||
|
||||
#+:ccl-has-delete-directory
|
||||
(if (directory-exists-p dirname)
|
||||
(ccl:delete-directory dirname)
|
||||
(ecase if-does-not-exist
|
||||
(:error (error "~S is not a directory" dirname))
|
||||
(:ignore nil)))
|
||||
|
||||
#-(or :allegro :sbcl :ccl-has-delete-directory)
|
||||
(walk-directory dirname
|
||||
(lambda (file)
|
||||
(cond ((directory-pathname-p file)
|
||||
#+:lispworks (lw:delete-directory file)
|
||||
#+:cmu (multiple-value-bind (ok err-number)
|
||||
(unix:unix-rmdir (namestring (truename file)))
|
||||
(unless ok
|
||||
(error "Error number ~A when trying to delete ~A"
|
||||
err-number file)))
|
||||
#+:scl (multiple-value-bind (ok errno)
|
||||
(unix:unix-rmdir (ext:unix-namestring (truename file)))
|
||||
(unless ok
|
||||
(error "~@<Error deleting ~S: ~A~@:>"
|
||||
file (unix:get-unix-error-msg errno))))
|
||||
#+:clisp (ext:delete-directory file)
|
||||
#+:openmcl (cl-fad-ccl:delete-directory file)
|
||||
#+:cormanlisp (win32:delete-directory file)
|
||||
#+:ecl (si:rmdir file)
|
||||
#+:clasp (core:rmdir file)
|
||||
#+(or :abcl :digitool) (delete-file file))
|
||||
(t (delete-file file))))
|
||||
:follow-symlinks nil
|
||||
:directories t
|
||||
:if-does-not-exist if-does-not-exist)
|
||||
(values))
|
||||
|
||||
(defun pathname-directory-pathname (pathname)
|
||||
"Returns a complete pathname representing the directory of
|
||||
PATHNAME. If PATHNAME is already a directory pathname (name NIL, type
|
||||
NIL) returns a pathname equal (as per pathname=) to it."
|
||||
(make-pathname :defaults pathname
|
||||
:name nil :type nil))
|
||||
|
||||
(defun pathname-parent-directory (pathname)
|
||||
"Returns a pathname which would, by name at least, contain PATHNAME
|
||||
as one of its direct children. Symlinks can make the parent/child
|
||||
relationship a like opaque, but generally speaking the value returned
|
||||
by this function is a directory name which contains PATHNAME.
|
||||
|
||||
The root directory, #P\"/\", is its own parent. The parent directory
|
||||
of a filename is the parent of the filename's dirname."
|
||||
(canonical-pathname
|
||||
(make-pathname :defaults pathname
|
||||
:directory (if (pathname-root-p pathname)
|
||||
(list :absolute)
|
||||
(append (or (pathname-directory pathname)
|
||||
(list :relative))
|
||||
(list :back))))))
|
||||
|
||||
(defun canonical-pathname (pathname)
|
||||
"Remove redundant information from PATHNAME.
|
||||
|
||||
This simply walks down PATHNAME's pathname-directory and drops \".\"
|
||||
directories, removes :back and its preceding element.
|
||||
|
||||
NB: This function does not access the filesystem, it only looks at the
|
||||
values in the pathname and works on their known (or assumed)
|
||||
meanings.
|
||||
|
||||
NB: Since this function does not access the filesystem it will only
|
||||
remove :BACK elements from the path (not :UP elements). Since some
|
||||
lisps, ccl/sbcl/clisp convert \"..\" in pathnames to :UP, and
|
||||
not :BACK, the actual utility of the function is limited."
|
||||
(let ((pathname (pathname pathname))) ;; just make sure to get a pathname object
|
||||
(loop
|
||||
with full-dir = (or (pathname-directory pathname)
|
||||
(list :relative))
|
||||
with canon-dir = (if (member (first full-dir) '(:relative :absolute))
|
||||
(list (pop full-dir))
|
||||
(list :relative))
|
||||
while full-dir
|
||||
do (cond
|
||||
((string= "." (first full-dir))
|
||||
(pop full-dir))
|
||||
((eql :back (second full-dir))
|
||||
(pop full-dir)
|
||||
(pop full-dir))
|
||||
(t (push (pop full-dir) canon-dir)))
|
||||
finally (return (make-pathname :defaults pathname :directory (nreverse canon-dir))))))
|
||||
|
||||
(defun merge-pathnames-as-directory (&rest pathnames)
|
||||
"Given a list of (probably relative) pathnames, this returns a single
|
||||
directory pathname containing the logical concatenation of them all.
|
||||
|
||||
The returned value is the current directory if one were to cd into
|
||||
each of PATHNAMES in order. For this reason an absolute pathname will,
|
||||
effectively, cancel the affect of any previous relative pathnames.
|
||||
|
||||
The returned value's defaults are taken from the first element of
|
||||
PATHNAMES (host, version and device).
|
||||
|
||||
NB: Since this function only looks at directory names the name and
|
||||
type of the elements of PATHNAMES are ignored. Make sure to properly
|
||||
use either trailing #\\/s, or pathname-as-directory, to get the
|
||||
expected results.
|
||||
|
||||
Examples:
|
||||
|
||||
(merge-pathnames-as-directory #P\"foo/\" #P\"bar/\") == #P\"foo/bar/\"
|
||||
(merge-pathnames-as-directory #P\"foo/\" #P\"./bar/\") == #P\"foo/./bar/\"
|
||||
(merge-pathnames-as-directory #P\"foo/\" #P\"/bar/\") == #P\"/bar/\"
|
||||
(merge-pathnames-as-directory #P\"foo/\" #P\"/bar/\" #P\"quux/file.txt\") == #P\"/bar/quux/\"
|
||||
"
|
||||
(if pathnames
|
||||
(let* ((pathnames (mapcar #'pathname pathnames))
|
||||
(defaults (first pathnames))
|
||||
(dir (pathname-directory defaults)))
|
||||
(loop for pathname in (rest pathnames)
|
||||
for directory = (pathname-directory pathname)
|
||||
do (ecase (first directory)
|
||||
;; this is equivalent to (:relative) == ".", so,
|
||||
;; for this function, just do nothing.
|
||||
((nil))
|
||||
(:absolute
|
||||
(setf dir directory))
|
||||
(:relative
|
||||
(setf dir (append dir (rest directory))))))
|
||||
(make-pathname :defaults defaults :directory dir :name nil :type nil))
|
||||
(make-pathname)))
|
||||
|
||||
(defun merge-pathnames-as-file (&rest pathnames)
|
||||
"Given a list of, probably relative, pathnames returns a single
|
||||
filename pathname containing the logical concatenation of them all.
|
||||
|
||||
The returned value's defaults are taken from the first element of
|
||||
PATHNAMES (host, version and device). The returned values's name, type
|
||||
and version are taken from the last element of PATHNAMES. The
|
||||
intervening elements are used only for their pathname-directory
|
||||
values.
|
||||
|
||||
Examples:
|
||||
|
||||
(merge-pathnames-as-file #P\"foo/\" #P\"bar.txt\") == #P\"foo/bar.txt\"
|
||||
(merge-pathnames-as-file #P\"foo/\" #P\"./bar.txt\") == #P\"foo/./bar.txt\"
|
||||
(merge-pathnames-as-file #P\"foo/\" #P\"/bar/README\") == #P\"/bar/README\"
|
||||
(merge-pathnames-as-file #P\"/foo/\" #P\"/bar/\" #P\"quux/file.txt\") == #P\"/bar/quux/file.txt\"
|
||||
"
|
||||
(cond ((null pathnames)
|
||||
(make-pathname))
|
||||
((null (cdr pathnames))
|
||||
(pathname-as-file (first pathnames)))
|
||||
(t
|
||||
(let ((file-name-part (first (last pathnames))))
|
||||
(make-pathname :defaults (apply #'merge-pathnames-as-directory pathnames)
|
||||
:name (pathname-name file-name-part)
|
||||
:type (pathname-type file-name-part)
|
||||
:version (pathname-version file-name-part))))))
|
||||
|
||||
(defmacro with-component-testers ((a b key) &body body)
|
||||
(let ((k (gensym)))
|
||||
`(let* ((,k ,key)
|
||||
(,a (funcall ,k ,a))
|
||||
(,b (funcall ,k ,b)))
|
||||
(labels ((components-are (test)
|
||||
(and (funcall test ,a) (funcall test ,b)))
|
||||
(components-are-member (values)
|
||||
(and (member ,a values :test #'eql)
|
||||
(member ,b values :test #'eql)
|
||||
(eql ,a ,b)))
|
||||
(components-are-string= ()
|
||||
(and (stringp ,a) (stringp ,b) (string= ,a ,b)))
|
||||
(components-are-every (test)
|
||||
(and (consp ,a)
|
||||
(consp ,b)
|
||||
(every test ,a ,b))))
|
||||
(declare (ignorable #'components-are #'components-are-member
|
||||
#'components-are-string= #'components-are-every))
|
||||
(if (or ,@body)
|
||||
(values t ,a ,b)
|
||||
nil)))))
|
||||
|
||||
(defun pathname-host-equal (a b)
|
||||
(with-component-testers (a b #'pathname-host)
|
||||
(eq a b)
|
||||
(components-are-member '(nil :unspecific))
|
||||
(components-are-string=)
|
||||
(components-are-every #'string=)))
|
||||
|
||||
(defun pathname-device-equal (a b)
|
||||
(with-component-testers (a b #'pathname-device)
|
||||
(components-are-member '(nil :unspecific))
|
||||
(components-are-string=)))
|
||||
|
||||
(defun pathname-directory-equal (a b)
|
||||
(with-component-testers (a b #'pathname-directory)
|
||||
(and (null a) (null b))
|
||||
(and (= (length a) (length b))
|
||||
(every (lambda (a b)
|
||||
(or (and (stringp a) (stringp b) (string= a b))
|
||||
(and (null a) (null b))
|
||||
(and (keywordp a) (keywordp b) (eql a b))))
|
||||
a b))))
|
||||
|
||||
(defun pathname-name-equal (a b)
|
||||
(with-component-testers (a b #'pathname-name)
|
||||
(components-are-member '(nil :wild :unspecific))
|
||||
(components-are-string=)))
|
||||
|
||||
(defun pathname-type-equal (a b)
|
||||
(with-component-testers (a b #'pathname-type)
|
||||
(components-are-member '(nil :wild :unspecific))
|
||||
(components-are-string=)))
|
||||
|
||||
(defun pathname-version-equal (a b)
|
||||
(with-component-testers (a b #'pathname-version)
|
||||
(and (null a) (null b))
|
||||
(components-are-member '(:wild :newest :unspecific))
|
||||
(and (integerp a) (integerp b) (= a b))))
|
||||
|
||||
(defun pathname-equal (a b)
|
||||
"Returns T if A and B represent the same pathname. This function
|
||||
does not access the filesystem, it only looks at the components of the
|
||||
two pathnames to test if they are the same (though by
|
||||
passing both A and B to probe-file one can make this function test for file 'sameness'.
|
||||
|
||||
Equality is defined as:
|
||||
|
||||
- strings that are string equal
|
||||
- symbol (including nil) or keywords which are eql
|
||||
- lists of the same length with equal (as per these rules) elements.
|
||||
|
||||
if any of these tree conditions is false for any of the components in
|
||||
A and B then A and B are different, otherwise they are the same.
|
||||
|
||||
NB: This function does not convert name strings to pathnames. So
|
||||
\"foo.txt\" and #P\"foo.txt\" are different pathnames."
|
||||
(if (and a b)
|
||||
(if (and (pathname-host-equal a b)
|
||||
(pathname-device-equal a b)
|
||||
(pathname-directory-equal a b)
|
||||
(pathname-name-equal a b)
|
||||
(pathname-type-equal a b)
|
||||
(pathname-version-equal a b))
|
||||
(values t a b)
|
||||
(values nil))
|
||||
(values nil)))
|
||||
|
||||
(defun pathname-absolute-p (a)
|
||||
"Returns true if A is an absolute pathname.
|
||||
|
||||
This simply tests if A's directory list starts with :ABSOLUTE"
|
||||
(eql :absolute (first (pathname-directory (pathname a)))))
|
||||
|
||||
(defun pathname-relative-p (a)
|
||||
"Returns true if A is a relative pathname.
|
||||
|
||||
This simply tests if A's directory starts with :RELATIVE."
|
||||
(let ((dir (pathname-directory (pathname a))))
|
||||
(or (null dir) (eql :relative (first dir)))))
|
||||
|
||||
(defun pathname-root-p (a)
|
||||
(let ((dir (pathname-directory (pathname a))))
|
||||
(and (eql :absolute (first dir))
|
||||
(= 1 (length dir)))))
|
||||
|
||||
(pushnew :cl-fad *features*)
|
||||
|
||||
;; stuff for Nikodemus Siivola's HYPERDOC
|
||||
;; see <http://common-lisp.net/project/hyperdoc/>
|
||||
;; and <http://www.cliki.net/hyperdoc>
|
||||
;; also used by LW-ADD-ONS
|
||||
|
||||
#-:abcl
|
||||
(defvar *hyperdoc-base-uri* "http://weitz.de/cl-fad/")
|
||||
|
||||
#-:abcl
|
||||
(let ((exported-symbols-alist
|
||||
(loop for symbol being the external-symbols of :cl-fad
|
||||
collect (cons symbol
|
||||
(concatenate 'string
|
||||
"#"
|
||||
(string-downcase symbol))))))
|
||||
(defun hyperdoc-lookup (symbol type)
|
||||
(declare (ignore type))
|
||||
(cdr (assoc symbol
|
||||
exported-symbols-alist
|
||||
:test #'eq))))
|
||||
|
|
@ -0,0 +1,157 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-FAD-TEST; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/cl-fad/test.lisp,v 1.12 2009/09/30 14:23:10 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
|
||||
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
|
||||
;;; * Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
|
||||
;;; * Redistributions in binary form must reproduce the above
|
||||
;;; copyright notice, this list of conditions and the following
|
||||
;;; disclaimer in the documentation and/or other materials
|
||||
;;; provided with the distribution.
|
||||
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
|
||||
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
||||
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
||||
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
||||
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
||||
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
(in-package #:cl-fad-test)
|
||||
|
||||
(defparameter *tmp-dir*
|
||||
#+(or :win32 :mswindows :windows) "c:\\tmp\\"
|
||||
#-(or :win32 :mswindows :windows) "/tmp/")
|
||||
|
||||
(defvar *test-counter* 0)
|
||||
|
||||
(defmacro assert* (form)
|
||||
`(progn
|
||||
(format t "Trying to assert ~A~%" ',form)
|
||||
(assert ,form)
|
||||
(format t "Test ~A passed.~%" (incf *test-counter*))))
|
||||
|
||||
(defun test ()
|
||||
(setq *test-counter* 0)
|
||||
|
||||
(assert* (path:= (path:catdir) #P""))
|
||||
(assert* (path:= (path:catdir #P"/") #P"/"))
|
||||
(assert* (path:= (path:catdir #P"a/" #P"b/") #P"a/b/"))
|
||||
(assert* (path:= (path:catdir #P"/a/" #P"/b/" #P"c/" #P"./d/" #P"e" #P"f/") #P"/b/c/./d/f/"))
|
||||
|
||||
(assert* (path:= (path:catfile) #P""))
|
||||
(assert* (path:= (path:catfile #P"R.txt") #P"R.txt"))
|
||||
(assert* (path:= (path:catfile #P"a/" #P"/b/" #P"R.txt") #P"/b/R.txt"))
|
||||
|
||||
|
||||
(let ((fad-dir (merge-pathnames (pathname-as-directory "fad-test")
|
||||
*tmp-dir*)))
|
||||
(delete-directory-and-files fad-dir :if-does-not-exist :ignore)
|
||||
(assert* (directory-pathname-p fad-dir))
|
||||
(assert* (directory-pathname-p (pathname *tmp-dir*)))
|
||||
(let ((foo-file (merge-pathnames "foo.lisp"
|
||||
fad-dir)))
|
||||
(assert* (not (directory-pathname-p foo-file)))
|
||||
(assert* (not (file-exists-p foo-file)))
|
||||
(assert* (not (file-exists-p fad-dir)))
|
||||
(with-open-file (out (ensure-directories-exist foo-file)
|
||||
:direction :output
|
||||
:if-does-not-exist :create)
|
||||
(write-string "NIL" out))
|
||||
(assert* (file-exists-p foo-file))
|
||||
(assert* (not (directory-exists-p foo-file)))
|
||||
(assert* (file-exists-p fad-dir))
|
||||
(assert* (directory-exists-p fad-dir))
|
||||
(assert* (equal fad-dir
|
||||
(pathname-as-directory fad-dir)))
|
||||
(assert* (equal foo-file
|
||||
(pathname-as-file foo-file)))
|
||||
(assert* (not (equal fad-dir
|
||||
(pathname-as-file fad-dir))))
|
||||
(assert* (not (equal foo-file
|
||||
(pathname-as-directory foo-file))))
|
||||
(dolist (name '("bar" "baz"))
|
||||
(let ((dir (merge-pathnames (pathname-as-directory name)
|
||||
fad-dir)))
|
||||
(dolist (name '("foo.text" "bar.lisp"))
|
||||
(let ((file (merge-pathnames name dir)))
|
||||
(with-open-file (out (ensure-directories-exist file)
|
||||
:direction :output
|
||||
:if-does-not-exist :create)
|
||||
(write-string "NIL" out))))))
|
||||
;; /tmp/fad-test/foo.lisp
|
||||
;; /tmp/fad-test/bar/bar.lisp
|
||||
;; /tmp/fad-test/bar/foo.text
|
||||
;; /tmp/fad-test/baz/bar.lisp
|
||||
;; /tmp/fad-test/baz/foo.text
|
||||
;; files : 5
|
||||
;; dirs : 3
|
||||
(let ((file-counter 0)
|
||||
(file-and-dir-counter 0)
|
||||
(bar-counter 0))
|
||||
(walk-directory fad-dir
|
||||
(lambda (file)
|
||||
(declare (ignore file))
|
||||
(incf file-counter)))
|
||||
;; file-counter => 5
|
||||
(walk-directory fad-dir
|
||||
(lambda (file)
|
||||
(declare (ignore file))
|
||||
(incf file-and-dir-counter))
|
||||
:directories t)
|
||||
;; file-and-dir-counter => 5 + 3
|
||||
(walk-directory fad-dir
|
||||
(lambda (file)
|
||||
(declare (ignore file))
|
||||
(incf bar-counter))
|
||||
:test (lambda (file)
|
||||
(string= (pathname-name file)
|
||||
"bar"))
|
||||
:directories t)
|
||||
;; do not traverse the baz directory
|
||||
(walk-directory fad-dir
|
||||
(lambda (file)
|
||||
(declare (ignore file))
|
||||
(incf file-and-dir-counter))
|
||||
:test (lambda (file)
|
||||
(not (and (directory-pathname-p file)
|
||||
(string= (first (last (pathname-directory file)))
|
||||
"baz"))))
|
||||
:directories :breadth-first)
|
||||
;; file-and-dir-counter => 5 + 3 + 2 dirs + 3 files
|
||||
(assert* (= 5 file-counter))
|
||||
(assert* (= 13 file-and-dir-counter))
|
||||
(assert* (= 2 bar-counter)))
|
||||
(let ((bar-file (merge-pathnames "bar.lisp" fad-dir)))
|
||||
(copy-file foo-file bar-file)
|
||||
(assert* (file-exists-p bar-file))
|
||||
(with-open-file (foo-stream foo-file :element-type '(unsigned-byte 8))
|
||||
(with-open-file (bar-stream bar-file :element-type '(unsigned-byte 8))
|
||||
(assert* (= (file-length foo-stream)
|
||||
(file-length bar-stream)))
|
||||
(loop for foo-byte = (read-byte foo-stream nil nil)
|
||||
for bar-byte = (read-byte bar-stream nil nil)
|
||||
while (and foo-byte bar-byte)
|
||||
do (assert* (eql foo-byte bar-byte))))))
|
||||
(let ((baz-dir (merge-pathnames (pathname-as-directory "baz")
|
||||
fad-dir))
|
||||
(list (mapcar #'namestring (list-directory fad-dir))))
|
||||
(assert* (find (namestring (truename foo-file)) list :test #'string=))
|
||||
(assert* (find (namestring (truename baz-dir)) list :test #'string=))
|
||||
(assert* (not (find (namestring (pathname-as-file baz-dir))
|
||||
list
|
||||
:test #'string=)))))
|
||||
(delete-directory-and-files fad-dir :if-does-not-exist :error)
|
||||
(assert* (not (file-exists-p fad-dir)))
|
||||
(assert* (not (directory-exists-p fad-dir))))
|
||||
(format t "All tests passed.~%"))
|
||||
|
|
@ -0,0 +1,62 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/cl-fad/load.lisp,v 1.9 2009/09/30 14:23:10 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
|
||||
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
|
||||
;;; * Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
|
||||
;;; * Redistributions in binary form must reproduce the above
|
||||
;;; copyright notice, this list of conditions and the following
|
||||
;;; disclaimer in the documentation and/or other materials
|
||||
;;; provided with the distribution.
|
||||
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
|
||||
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
||||
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
||||
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
||||
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
||||
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
(in-package :cl-user)
|
||||
|
||||
(defparameter *cl-fad-base-directory*
|
||||
(make-pathname :name nil :type nil :version nil
|
||||
:defaults (parse-namestring *load-truename*)))
|
||||
|
||||
#+:allegro (require :osi)
|
||||
#+:sbcl (require :sb-executable)
|
||||
#+:sbcl (require :sb-posix)
|
||||
|
||||
(let ((cl-fad-base-directory
|
||||
(make-pathname :name nil :type nil :version nil
|
||||
:defaults (parse-namestring *load-truename*))))
|
||||
(let (must-compile)
|
||||
#+:cormanlisp (declare (ignore must-compile))
|
||||
(dolist (file '("packages"
|
||||
#+:cormanlisp "corman"
|
||||
#+:openmcl "openmcl"
|
||||
"fad"))
|
||||
(let ((pathname (make-pathname :name file :type "lisp" :version nil
|
||||
:defaults cl-fad-base-directory)))
|
||||
;; don't use COMPILE-FILE in Corman Lisp, it's broken - LOAD
|
||||
;; will yield compiled functions anyway
|
||||
#-:cormanlisp
|
||||
(let ((compiled-pathname (compile-file-pathname pathname)))
|
||||
(unless (and (not must-compile)
|
||||
(probe-file compiled-pathname)
|
||||
(< (file-write-date pathname)
|
||||
(file-write-date compiled-pathname)))
|
||||
(setq must-compile t)
|
||||
(compile-file pathname))
|
||||
(setq pathname compiled-pathname))
|
||||
(load pathname)))))
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CCL; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/cl-fad/openmcl.lisp,v 1.6 2009/09/30 14:23:10 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
|
||||
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
|
||||
;;; * Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
|
||||
;;; * Redistributions in binary form must reproduce the above
|
||||
;;; copyright notice, this list of conditions and the following
|
||||
;;; disclaimer in the documentation and/or other materials
|
||||
;;; provided with the distribution.
|
||||
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS 'AS IS' AND ANY EXPRESSED
|
||||
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
||||
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
||||
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
||||
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
||||
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
(in-package :cl-fad)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(flet ((ccl-function-feature (symbol-name feature)
|
||||
(let ((symbol (find-symbol symbol-name :ccl)))
|
||||
(when (and symbol (fboundp symbol))
|
||||
(pushnew feature *features*)))))
|
||||
(ccl-function-feature "%RMDIR" :ccl-has-%rmdir)
|
||||
(ccl-function-feature "DELETE-DIRECTORY" :ccl-has-delete-directory)))
|
||||
|
||||
(defpackage :cl-fad-ccl
|
||||
(:use :cl)
|
||||
(:export delete-directory)
|
||||
(:import-from :ccl
|
||||
:%realpath
|
||||
:signal-file-error
|
||||
:native-translated-namestring
|
||||
:with-cstrs)
|
||||
#+ccl-has-%rmdir
|
||||
(:import-from :ccl :%rmdir)
|
||||
#+ccl-has-delete-directory
|
||||
(:import-from :ccl :delete-directory))
|
||||
|
||||
(in-package :cl-fad-ccl)
|
||||
|
||||
#-ccl-has-%rmdir
|
||||
(defun %rmdir (name)
|
||||
(with-cstrs ((n name))
|
||||
(#_rmdir n)))
|
||||
|
||||
;;; ClozureCL 1.6 introduced ccl:delete-directory with semantics that
|
||||
;;; are acceptably similar to this "legacy" definition.
|
||||
;;;
|
||||
;;; Except this legacy definition is not recursive, hence this function is
|
||||
;;; used only if there is no :CCL-HAS-DELETE-DIRECTORY feature.
|
||||
|
||||
#-ccl-has-delete-directory
|
||||
(defun delete-directory (path)
|
||||
(let* ((namestring (native-translated-namestring path)))
|
||||
(when (%realpath namestring)
|
||||
(let* ((err (%rmdir namestring)))
|
||||
(or (eql 0 err) (signal-file-error err path))))))
|
||||
|
||||
|
|
@ -0,0 +1,87 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||
;;; $Header: /usr/local/cvsrep/cl-fad/packages.lisp,v 1.12 2009/09/30 14:23:10 edi Exp $
|
||||
|
||||
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
|
||||
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
|
||||
;;; * Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
|
||||
;;; * Redistributions in binary form must reproduce the above
|
||||
;;; copyright notice, this list of conditions and the following
|
||||
;;; disclaimer in the documentation and/or other materials
|
||||
;;; provided with the distribution.
|
||||
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
|
||||
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
||||
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
||||
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
||||
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
||||
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
(in-package #:cl-user)
|
||||
|
||||
(defpackage :cl-fad
|
||||
(:nicknames :fad)
|
||||
(:use :cl)
|
||||
#+:allegro
|
||||
(:shadow :copy-file
|
||||
:delete-directory-and-files)
|
||||
#+:abcl
|
||||
(:shadow :list-directory)
|
||||
(:export :copy-file
|
||||
:copy-stream
|
||||
:delete-directory-and-files
|
||||
:directory-exists-p
|
||||
:directory-pathname-p
|
||||
:file-exists-p
|
||||
:list-directory
|
||||
:pathname-as-directory
|
||||
:pathname-as-file
|
||||
:pathname-directory-pathname
|
||||
:pathname-equal
|
||||
:pathname-parent-directory
|
||||
:pathname-absolute-p
|
||||
:pathname-relative-p
|
||||
:pathname-root-p
|
||||
|
||||
:canonical-pathname
|
||||
:merge-pathnames-as-directory
|
||||
:merge-pathnames-as-file
|
||||
|
||||
:walk-directory
|
||||
|
||||
:open-temporary
|
||||
:with-output-to-temporary-file
|
||||
:with-open-temporary-file
|
||||
:*default-template*
|
||||
:invalid-temporary-pathname-template
|
||||
:cannot-create-temporary-file
|
||||
#+win32 #:missing-temp-environment-variable))
|
||||
|
||||
(defpackage :path
|
||||
(:use)
|
||||
(:documentation "Rexporting certain functions from the cl-fad package with shorter names.
|
||||
|
||||
This package provides no functionality, it serves only to make file
|
||||
system intensive code easier to read (for unix people at least).")
|
||||
(:export #:dirname
|
||||
#:basename
|
||||
#:-e
|
||||
#:-d
|
||||
#:catfile
|
||||
#:catdir
|
||||
#:rm-r
|
||||
#:=
|
||||
|
||||
#:absolute-p
|
||||
#:relative-p
|
||||
#:root-p))
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
(in-package :common-lisp-user)
|
||||
|
||||
(defpackage :cl-fad-test
|
||||
(:use :cl :cl-fad :unit-test)
|
||||
(:export :test))
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
(in-package :cl-fad)
|
||||
|
||||
(defmacro defalias (name args realname)
|
||||
`(progn
|
||||
(defun ,name ,args
|
||||
,(if (eql '&rest (first args))
|
||||
`(apply #',realname ,(second args))
|
||||
`(,realname ,@args)))
|
||||
(define-compiler-macro ,name (&rest args)
|
||||
(list* ',realname args))))
|
||||
|
||||
(defalias path:dirname (pathname) cl-fad:pathname-directory-pathname)
|
||||
|
||||
(defun path:basename (pathname) (pathname (file-namestring pathname)))
|
||||
|
||||
(defalias path:-e (pathname) cl-fad:file-exists-p)
|
||||
|
||||
(defalias path:-d (directory) cl-fad:directory-exists-p)
|
||||
|
||||
(defalias path:catfile (&rest pathnames) cl-fad:merge-pathnames-as-file)
|
||||
|
||||
(defalias path:catdir (&rest pathnames) cl-fad:merge-pathnames-as-directory)
|
||||
|
||||
(defalias path:= (a b) cl-fad:pathname-equal)
|
||||
|
||||
(defalias path:absolute-p (pathname) cl-fad:pathname-absolute-p)
|
||||
|
||||
(defalias path:relative-p (pathname) cl-fad:pathname-relative-p)
|
||||
|
||||
(defalias path:root-p (pathname) cl-fad:pathname-root-p)
|
||||
|
||||
(defalias path:rm-r (pathname) cl-fad:delete-directory-and-files)
|
||||
|
|
@ -0,0 +1,173 @@
|
|||
(in-package :cl-fad)
|
||||
|
||||
(defparameter *default-template* "TEMPORARY-FILES:TEMP-%")
|
||||
|
||||
(defparameter *max-tries* 10000)
|
||||
|
||||
(defvar *name-random-state* (make-random-state t))
|
||||
|
||||
;; from XCVB
|
||||
(eval-when (:load-toplevel :execute)
|
||||
(defun getenv (x)
|
||||
"Query the libc runtime environment. See getenv(3)."
|
||||
(declare (ignorable x))
|
||||
#+(or abcl clisp xcl) (ext:getenv x)
|
||||
#+allegro (sys:getenv x)
|
||||
#+clozure (ccl:getenv x)
|
||||
#+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
|
||||
#+cormanlisp
|
||||
(let* ((buffer (ct:malloc 1))
|
||||
(cname (ct:lisp-string-to-c-string x))
|
||||
(needed-size (win:getenvironmentvariable cname buffer 0))
|
||||
(buffer1 (ct:malloc (1+ needed-size))))
|
||||
(prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
|
||||
nil
|
||||
(ct:c-string-to-lisp-string buffer1))
|
||||
(ct:free buffer)
|
||||
(ct:free buffer1)))
|
||||
#+ecl (si:getenv x)
|
||||
#+gcl (system:getenv x)
|
||||
#+lispworks (lispworks:environment-variable x)
|
||||
#+mcl (ccl:with-cstrs ((name x))
|
||||
(let ((value (_getenv name)))
|
||||
(unless (ccl:%null-ptr-p value)
|
||||
(ccl:%get-cstring value))))
|
||||
#+sbcl (sb-ext:posix-getenv x)
|
||||
#+clasp (ext:getenv x)
|
||||
#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl clasp)
|
||||
(error "~S is not supported on your implementation" 'getenv))
|
||||
|
||||
(defun directory-from-environment (environment-variable-name)
|
||||
(let ((string (getenv environment-variable-name)))
|
||||
(when (plusp (length string))
|
||||
(pathname-as-directory string))))
|
||||
|
||||
#+win32
|
||||
(define-condition missing-temp-environment-variable (error)
|
||||
()
|
||||
(:report (lambda (condition stream)
|
||||
(declare (ignore condition))
|
||||
(format stream "the TEMP environment variable has not been found, cannot continue"))))
|
||||
|
||||
#+win32
|
||||
(defun get-default-temporary-directory ()
|
||||
(or (directory-from-environment "TEMP")
|
||||
(error 'missing-temp-environment-variable)))
|
||||
|
||||
#-win32
|
||||
(defun get-default-temporary-directory ()
|
||||
(or (directory-from-environment "TMPDIR")
|
||||
(and #-clisp (probe-file #P"/tmp/")
|
||||
#+clisp (ext:probe-directory #P"/tmp/")
|
||||
#P"/tmp/")))
|
||||
|
||||
(handler-case
|
||||
(logical-pathname-translations "TEMPORARY-FILES")
|
||||
(error ()
|
||||
(alexandria:if-let (default-temporary-directory (get-default-temporary-directory))
|
||||
(setf (logical-pathname-translations "TEMPORARY-FILES") `(("*.*.*" ,default-temporary-directory)))
|
||||
(warn "could not automatically determine a default mapping for TEMPORARY-FILES")))))
|
||||
|
||||
;; locking for multi-threaded operation with unsafe random function
|
||||
|
||||
(defvar *create-file-name-lock* (bordeaux-threads:make-lock "Temporary File Name Creation Lock"))
|
||||
|
||||
(defmacro with-file-name-lock-held (() &body body)
|
||||
`(bordeaux-threads:with-lock-held (*create-file-name-lock*)
|
||||
,@body))
|
||||
|
||||
(defun generate-random-string ()
|
||||
(with-file-name-lock-held ()
|
||||
(format nil "~:@(~36,8,'0R~)" (random (expt 36 8) *name-random-state*))))
|
||||
|
||||
(define-condition invalid-temporary-pathname-template (error)
|
||||
((string :initarg :string))
|
||||
(:report (lambda (condition stream)
|
||||
(with-slots (string) condition
|
||||
(format stream "invalid temporary file name template ~S, must contain a percent sign that is to be replaced by a random string" string)))))
|
||||
|
||||
(defun generate-random-pathname (template random-string-generator)
|
||||
(let ((percent-position (or (position #\% template)
|
||||
(error 'invalid-temporary-pathname-template :string template))))
|
||||
(merge-pathnames (concatenate 'string
|
||||
(subseq template 0 percent-position)
|
||||
(funcall random-string-generator)
|
||||
(subseq template (1+ percent-position))))))
|
||||
|
||||
(define-condition cannot-create-temporary-file (error)
|
||||
((template :initarg :template)
|
||||
(max-tries :initarg :max-tries))
|
||||
(:report (lambda (condition stream)
|
||||
(with-slots (template max-tries) condition
|
||||
(format stream "cannot create temporary file with template ~A, giving up after ~D attempt~:P"
|
||||
template max-tries)))))
|
||||
|
||||
(defun open-temporary (&rest open-arguments
|
||||
&key
|
||||
(template *default-template*)
|
||||
(generate-random-string 'generate-random-string)
|
||||
(max-tries *max-tries*)
|
||||
(direction :output)
|
||||
&allow-other-keys)
|
||||
"Create a file with a randomly generated name and return the opened
|
||||
stream. The resulting pathname is generated from TEMPLATE, which
|
||||
is a string representing a pathname template. A percent sign (%)
|
||||
in that string is replaced by a randomly generated string to make
|
||||
the filename unique. The default for TEMPLATE places temporary
|
||||
files in the TEMPORARY-FILES logical pathname host, which is
|
||||
automatically set up in a system specific manner. The file name
|
||||
generated from TEMPLATE is merged with *DEFAULT-PATHNAME-DEFAULTS*,
|
||||
so random pathnames relative to that directory can be generated by
|
||||
not specifying a directory in TEMPLATE.
|
||||
|
||||
GENERATE-RANDOM-STRING can be passed to override the default
|
||||
function that generates the random name component. It should
|
||||
return a random string consisting of characters that are permitted
|
||||
in a pathname (logical or physical, depending on TEMPLATE).
|
||||
|
||||
The name of the temporary file can be accessed calling the PATHNAME
|
||||
function on STREAM. For convenience, the temporary file is opened
|
||||
on the physical pathname, i.e. if the TEMPLATE designate a logical
|
||||
pathname the translation to a physical pathname is performed before
|
||||
opening the stream.
|
||||
|
||||
In order to create a unique file name, OPEN-TEMPORARY may loop
|
||||
internally up to MAX-TRIES times before giving up and signalling a
|
||||
CANNOT-CREATE-TEMPORARY-FILE condition."
|
||||
(loop thereis (apply #'open
|
||||
(translate-logical-pathname (generate-random-pathname template generate-random-string))
|
||||
:direction direction
|
||||
:if-exists nil
|
||||
(alexandria:remove-from-plist open-arguments :template :generate-random-string :max-tries))
|
||||
repeat max-tries
|
||||
finally (error 'cannot-create-temporary-file
|
||||
:template template
|
||||
:max-tries max-tries)))
|
||||
|
||||
(defmacro with-output-to-temporary-file ((stream &rest args) &body body)
|
||||
"Create a temporary file using OPEN-TEMPORARY with ARGS and run BODY
|
||||
with STREAM bound to the temporary file stream. Returns the
|
||||
pathname of the file that has been created. See OPEN-TEMPORARY for
|
||||
permitted options."
|
||||
`(with-open-stream (,stream (open-temporary ,@args))
|
||||
,@body
|
||||
(pathname ,stream)))
|
||||
|
||||
(defmacro with-open-temporary-file ((stream &rest args &key keep &allow-other-keys) &body body)
|
||||
"Create a temporary file using OPEN-TEMPORARY with ARGS and run BODY
|
||||
with STREAM bound to the temporary file stream. Returns the values
|
||||
returned by BODY. By default, the file is deleted when BODY is
|
||||
exited. If a true value is passed in KEEP, the file is not deleted
|
||||
when the body is exited. See OPEN-TEMPORARY for more permitted
|
||||
options."
|
||||
`(with-open-stream (,stream (open-temporary ,@(alexandria:remove-from-plist args :keep)))
|
||||
#+sbcl
|
||||
(declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
|
||||
,(if (and (constantp keep)
|
||||
keep)
|
||||
`(progn ,@body)
|
||||
`(unwind-protect
|
||||
(progn ,@body)
|
||||
(unless ,keep
|
||||
(close ,stream)
|
||||
(delete-file (pathname ,stream)))))))
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
(in-package :cl-fad-test)
|
||||
|
||||
(deftest 'temporary-file 'with-output-to-temporary-file ()
|
||||
(let ((pathname (with-output-to-temporary-file (f)
|
||||
(write-string "hello" f))))
|
||||
(test-assert (probe-file pathname))
|
||||
(test-equal (alexandria:read-file-into-string pathname) "hello")
|
||||
(delete-file pathname)))
|
||||
|
||||
(deftest 'temporary-file 'with-open-temporary-file-keep ()
|
||||
|
||||
(let ((pathname (with-open-temporary-file (f :keep nil)
|
||||
(pathname f))))
|
||||
(test-assert (null (probe-file pathname))))
|
||||
(let ((pathname (with-open-temporary-file (f :keep t)
|
||||
(pathname f))))
|
||||
(test-assert (probe-file pathname))
|
||||
(delete-file pathname))
|
||||
|
||||
(let* ((keep nil)
|
||||
(pathname (with-open-temporary-file (f :keep keep)
|
||||
(pathname f))))
|
||||
(test-assert (null (probe-file pathname))))
|
||||
(let* ((keep t)
|
||||
(pathname (with-open-temporary-file (f :keep keep)
|
||||
(pathname f))))
|
||||
(test-assert (probe-file pathname))
|
||||
(delete-file pathname)))
|
||||
|
||||
(deftest 'temporary-file 'template-tests ()
|
||||
;; error is signalled when template does not contain a percent sign.
|
||||
(let ((*default-template* "foo"))
|
||||
(test-condition (with-open-temporary-file (f :keep nil))
|
||||
'invalid-temporary-pathname-template))
|
||||
;; file name template occurs in generated file name (for logical path name)
|
||||
(let* ((*default-template* "temporary-files:bla%.txt")
|
||||
(pathname (with-open-temporary-file (f :keep nil)
|
||||
(pathname f))))
|
||||
(test-assert (cl-ppcre:scan "(?i)bla.*\\.txt$" (namestring pathname))))
|
||||
;; file name template occurs in generated file name (for pysical path name)
|
||||
(let* ((*default-template* (concatenate 'string
|
||||
(namestring (translate-logical-pathname "temporary-files:"))
|
||||
"bla%.txt"))
|
||||
(pathname (with-open-temporary-file (f :keep nil)
|
||||
(pathname f))))
|
||||
(test-assert (cl-ppcre:scan "(?i)bla.*\\.txt$" (namestring pathname)))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,400 @@
|
|||
Version 2.1.1
|
||||
2019-04-07
|
||||
Version 2.0.11
|
||||
2015-08-26
|
||||
Fix for type checks in LispWorks 7 (Martin Simmons)
|
||||
|
||||
Version 2.0.10
|
||||
2015-05-28
|
||||
Add :author/:license/:description fields to .asd files (Hans Huebner)
|
||||
Move inlined definitions before they are used. (Stas Boukarev)
|
||||
|
||||
Version 2.0.9
|
||||
2014-11-28
|
||||
Merge branch 'master' of github.com:edicl/cl-ppcre (Hans Huebner)
|
||||
Merge pull request #20 from billitch/master (Hans Huebner)
|
||||
Typo in CREATE-SCANNER documentation. (Thomas de Grivel)
|
||||
|
||||
Version 2.0.8
|
||||
2014-11-28
|
||||
Update support info (Hans Huebner)
|
||||
|
||||
Version 2.0.7
|
||||
2014-01-23
|
||||
Doc: Update repository location, remove the darcs mirror. (Stas Boukarev)
|
||||
|
||||
Version 2.0.6
|
||||
2015-01-05
|
||||
Fix failing tests and spurious compiler warnings
|
||||
|
||||
Version 2.0.5
|
||||
2014-01-05
|
||||
Fix spurious test failures (Edi Weitz)
|
||||
|
||||
Version 2.0.4
|
||||
2013-04-13
|
||||
Rewrite SEQ without using recursion (Stas Boukarev)
|
||||
:property and :invert-property scanning bug fix (Cyrus Harmon)
|
||||
Improve documentation (David Lindes)
|
||||
|
||||
Version 2.0.3
|
||||
2009-10-28
|
||||
Use LW:SIMPLE-TEXT-STRING throughout for LispWorks
|
||||
|
||||
Version 2.0.2
|
||||
2009-09-17
|
||||
Fixed typo in chartest.lisp (caught by Peter Seibel)
|
||||
Appease CCL (thanks to Hans Hübner)
|
||||
|
||||
Version 2.0.1
|
||||
2008-09-02
|
||||
Fixed faulty declaration (caught by Brent Fulgham)
|
||||
|
||||
Version 2.0.0
|
||||
2008-07-24
|
||||
Added named properties (\p{foo})
|
||||
Added Unicode support
|
||||
Introduced test functions for character classes
|
||||
Added optional test function optimization
|
||||
Cleaned up test suite, removed performance cruft
|
||||
Removed the various alternative system definitions (too much maintenance work)
|
||||
Exported PARSE-STRING
|
||||
Changed default value of *USE-BMH-MATCHERS*
|
||||
General cleanup
|
||||
Lots of documentation additions
|
||||
|
||||
Version 1.4.1
|
||||
2008-07-03
|
||||
Skip non-characters in CREATE-RANGES-FROM-SET
|
||||
|
||||
Version 1.4.0
|
||||
2008-07-03
|
||||
Replaced hash tables with charsets (by Nikodemus Siivola)
|
||||
Get rid of duplicates in REGEX-APROPOS(-LIST)
|
||||
|
||||
Version 1.3.3
|
||||
2008-06-25
|
||||
Let the Lisp decide how it wants to enlarge its hash tables
|
||||
Fixed anchors for special variables in docs
|
||||
Fixed typo in docs (thanks to Jason S. Cornez)
|
||||
|
||||
Version 1.3.2
|
||||
2007-09-13
|
||||
Updated docs and ChangeLog to be really in sync with 1.3.1 changes (thanks to Sébastien Saint-Sevin)
|
||||
|
||||
Version 1.3.1
|
||||
2007-08-24
|
||||
Second return value for REGEX-REPLACE and REGEX-REPLACE-ALL (patch by Matthew Sachs)
|
||||
|
||||
Version 1.3.0
|
||||
2007-03-24
|
||||
Optional support for named registers (patch by Ondrej Svitek)
|
||||
|
||||
Version 1.2.19
|
||||
2007-01-16
|
||||
Fixed behaviour of look-behind in repeated scans (caught by RegexCoach user Hans Jud)
|
||||
|
||||
Version 1.2.18
|
||||
2006-10-12
|
||||
Changed default element type for LispWorks
|
||||
Fixed documentation for REGEX-REPLACE-ALL
|
||||
|
||||
Version 1.2.17
|
||||
2006-10-11
|
||||
Fixed bug in DO-SCANS which affected anchors (caught by RegexCoach user Laurent Taupiac)
|
||||
Update link for 'man perlre' (thanks to Ricardo Boccato Alves)
|
||||
|
||||
Version 1.2.16
|
||||
2006-07-16
|
||||
Added :ELEMENT-TYPE to REGEX-REPLACE(-ALL)
|
||||
|
||||
Version 1.2.15
|
||||
2006-07-03
|
||||
Added :REGEX tag to parse tree syntax (thanks to Frédéric Jolliton)
|
||||
|
||||
Version 1.2.14
|
||||
2006-05-24
|
||||
Added missing </code> tag in docs (thanks to Wojciech Kaczmarek)
|
||||
Fixed IMPORT statement for LW
|
||||
|
||||
Version 1.2.13
|
||||
2005-12-06
|
||||
Fixed bug involving *REAL-START-POS* (caught by "tichy")
|
||||
|
||||
Version 1.2.12
|
||||
2005-11-01
|
||||
REGEX-APROPOS-AUX now also uses :INHERITED
|
||||
Fixed typo in parser.lisp (thanks to Derek Peschel)
|
||||
Fixed value of *REGEX-CHAR-CODE-LIMIT* in docs and test (thanks to Christophe Rhodes)
|
||||
|
||||
Version 1.2.11
|
||||
2005-08-01
|
||||
Added external format for SBCL in ppcre-tests.lisp (thanks to Christophe Rhodes)
|
||||
|
||||
Version 1.2.10
|
||||
2005-07-20
|
||||
Fixed bug in CHAR-SEARCHER-AUX (caught by Peter Schuller)
|
||||
Don't redefine what's already there (for LispWorks)
|
||||
|
||||
Version 1.2.9
|
||||
2005-06-27
|
||||
Hide compiler macros from CCL (thanks to Karsten Poeck)
|
||||
|
||||
Version 1.2.8
|
||||
2005-06-10
|
||||
Change EQ to EQL in REGEX-LENGTH for ANSI conformance and ABCL compatibility (thanks to Peter Graves)
|
||||
|
||||
Version 1.2.7
|
||||
2005-05-16
|
||||
Added lispworks-defsystem.lisp (thanks to Wade Humeniuk)
|
||||
Fixed bug in WORD-BOUNDARY-P
|
||||
|
||||
Version 1.2.6
|
||||
2005-04-13
|
||||
Added some DEFGENERICs to appease SBCL (thanks to Alan Shields)
|
||||
Removed wrong FTYPE declaration for STR (thanks to Alan Shields)
|
||||
|
||||
Version 1.2.5
|
||||
2005-03-09
|
||||
Customizable optimize qualities (thanks to Damien Kick)
|
||||
|
||||
Version 1.2.4
|
||||
2005-03-07
|
||||
Changed DEBUG optimize quality from 0 to 1
|
||||
|
||||
Version 1.2.3
|
||||
2005-02-02
|
||||
Wrapped WITH-COMPILATION-UNIT around loop in load.lisp
|
||||
|
||||
Version 1.2.2
|
||||
2005-02-02
|
||||
Fixed bug in hash table optimization (introduced in 1.1.0)
|
||||
|
||||
Version 1.2.1
|
||||
2005-01-25
|
||||
There was a wrong read-time conditional in api.lisp, sorry
|
||||
|
||||
Version 1.2.0
|
||||
2005-01-24
|
||||
AllegroCL compatibility mode
|
||||
Fixed broken load.lisp file (caught by Jim Prewett and Zach Beane)
|
||||
|
||||
Version 1.1.0
|
||||
2005-01-23
|
||||
Cleaned up load.lisp and cl-ppcre.asd
|
||||
Make large hash tables smaller, if possible
|
||||
Correct treatment of constant regular expressions in DO-SCANS
|
||||
|
||||
Version 1.0.0
|
||||
2004-12-22
|
||||
Special anniversary release... :)
|
||||
|
||||
Version 0.9.4
|
||||
2004-12-18
|
||||
Fixed bug in NORMALIZE-VAR-LIST (caught by Dave Roberts)
|
||||
|
||||
Version 0.9.3
|
||||
2004-12-09
|
||||
Fixed bug in CREATE-SCANNER-AUX (caught by Allan Ruttenberg and Gary Byers)
|
||||
|
||||
Version 0.9.2
|
||||
2004-12-06
|
||||
More compiler macros (thanks to Allan Ruttenberg)
|
||||
|
||||
Version 0.9.1
|
||||
2004-11-29
|
||||
Shortcuts for REGISTER-GROUPS-BIND and DO-REGISTER-GROUPS (suggested by Alexander Kjeldaas)
|
||||
|
||||
Version 0.9.0
|
||||
2004-10-14
|
||||
Experimental support for "filters"
|
||||
Bugfix for standalone regular expressions (ACCUMULATE-START-P wasn't set to NIL)
|
||||
|
||||
Version 0.8.1
|
||||
2004-09-30
|
||||
Patches for Genera 8.5 (thanks to Patrick O'Donnell)
|
||||
|
||||
Version 0.8.0
|
||||
2004-09-16
|
||||
Added parse tree synonyms (thanks to Patrick O'Donnell)
|
||||
|
||||
Version 0.7.9
|
||||
2004-07-13
|
||||
Fixed bug in DO-SCANS (caught by Jan Rychter)
|
||||
|
||||
Version 0.7.8
|
||||
2004-07-13
|
||||
New SIMPLE-CALLS keyword argument for REGEX-REPLACE(-ALL)
|
||||
Added environment parameter to compiler macros (thanks to c.l.l article <aczhx5hj.fsf@ccs.neu.edu> by Joe Marshall)
|
||||
Added compiler macros for SCAN-TO-STRINGS and REGEX-REPLACE(-ALL) (they somehow got lost)
|
||||
|
||||
Version 0.7.7
|
||||
2004-05-19
|
||||
Fixed bug in NEWLINE-SKIPPER (caught by RegexCoach user Thomas-Paz Hartman)
|
||||
Added doc strings for PPCRE-SYNTAX-ERROR and friends (after playing with slime-apropos-package)
|
||||
Added hyperdoc support
|
||||
|
||||
Version 0.7.6
|
||||
2004-04-20
|
||||
The closures created by CREATE-BMH-MATCHER now cleanly cope with negative arguments (bug caught by Damien Kick)
|
||||
|
||||
Version 0.7.5
|
||||
2004-04-19
|
||||
Fixed a bug with constant-length repetitions of . (dot) in single-line mode (caught by RegexCoach user Lee Gold)
|
||||
|
||||
Version 0.7.4
|
||||
2004-02-16
|
||||
Fixed wrong call to SIGNAL-PPCRE-SIGNAL-ERROR in lexer.lisp (caught by Peter Graves)
|
||||
Added :CL-PPCRE to *FEATURES* (for CL-INTERPOL)
|
||||
Compiler macro for SPLIT
|
||||
|
||||
Version 0.7.3
|
||||
2004-01-28
|
||||
Fixed bug in CURRENT-MIN-REST for lookaheads (reported by RegexCoach user Thomas-Paz Hartman)
|
||||
Added tests for this bug
|
||||
|
||||
Version 0.7.2
|
||||
2004-01-27
|
||||
Fixed typo (SUBSEQ/NSUBSEQ) in SPLIT (thanks to Alan Ruttenberg)
|
||||
Updated docs with respect to ECL (thanks to Alex Mizrahi)
|
||||
Mention FreeBSD port in docs
|
||||
|
||||
Version 0.7.1
|
||||
2003-10-24
|
||||
Fixed version numbers in docs (thanks to Sébastien Saint-Sevin)
|
||||
|
||||
Version 0.7.0
|
||||
2003-10-23
|
||||
New macros REGISTER-GROUPS-BIND and DO-REGISTER-GROUPS
|
||||
Added SHAREP keyword argument to most API functions and macros
|
||||
Mention CL-INTERPOL in docs
|
||||
Partial code cleanup (using WITH-UNIQUE-NAMES and REBINDING)
|
||||
|
||||
Version 0.6.1
|
||||
2003-10-11
|
||||
Added EXTERNAL-FORMAT keyword args to CL-PPCRE-TEST:TEST for some CLs (thanks to JP Massar and Scott D. Kalter)
|
||||
Fixed bug with REGEX-REPLACE and REGEX-REPLACE-ALL when (= START END) was true
|
||||
Added doc sections for quoting problems and backslash confusions (thanks to conversations with Peter Seibel)
|
||||
Disable quoting in definition of QUOTE-SECTIONS so you can always safely rebuild CL-PPCRE
|
||||
|
||||
Version 0.6.0
|
||||
2003-10-07
|
||||
CL-PPCRE now has its own condition types
|
||||
Added support for Perl's \Q and \E (Peter Seibel convinced me to do it) - see QUOTE-META-CHARS and *ALLOW-QUOTING*
|
||||
Added tests for this new feature
|
||||
Threaded tests are more verbose now and use only keyword args
|
||||
|
||||
Version 0.5.9
|
||||
2003-10-03
|
||||
Changed "^" optimizations with respect to constant end strings with offsets (bug caught by Yexuan Gui)
|
||||
Added tests for this bug
|
||||
Removed *.dos files from CL-PPCRE-TEST tests (thanks to JP Massar)
|
||||
Added threaded tests for SBCL (thanks to Christophe Rhodes)
|
||||
|
||||
Version 0.5.8
|
||||
2003-09-17
|
||||
Optimizations for ".*" were too optimistic when look-behinds were involved
|
||||
Added tests for this bug
|
||||
Removed *.dos files
|
||||
|
||||
Version 0.5.7
|
||||
2003-08-20
|
||||
Fixed (CL-PPCRE:SCAN "(.)X$" "ABCX" :START 4) bug (spotted by Tibor Simko)
|
||||
Forgot to export *REGEX-CHAR-CODE-LIMIT* in Corman version of DEFPACKAGE
|
||||
Removed Emacs local variables from source code (finally...)
|
||||
Mention Gentoo in docs
|
||||
|
||||
Version 0.5.6
|
||||
2003-06-30
|
||||
Replaced wrong COPY-REGEX code for WORD-BOUNDARY objects (detected by Max Goldberg)
|
||||
Added info about possible TRUENAME problems with ACL in README (thanks to Kevin Layer for providing a patch for this)
|
||||
|
||||
Version 0.5.5
|
||||
2003-06-09
|
||||
Patch for SBCL/Debian compatibility by Kevin Rosenberg
|
||||
Simpler version of compiler macro
|
||||
Availability through asdf-install
|
||||
|
||||
Version 0.5.4
|
||||
2003-04-09
|
||||
Added DESTRUCTIVE keyword to CREATE-SCANNER
|
||||
|
||||
Version 0.5.3
|
||||
2003-03-31
|
||||
Fixed bug in REGEX-REPLACE (replacement string couldn't contain literal backslash)
|
||||
Fixed bug in definition of CHAR-CLASS (since 0.5.0 the hash slot may be NIL - CMUCL's new PCL detects this)
|
||||
Micro-optimization in INSERT-CHAR-CLASS-TESTER: CHAR-NOT-GREATERP instead of CHAR-DOWNCASE
|
||||
|
||||
Version 0.5.2
|
||||
2003-03-28
|
||||
Better compiler macro (thanks to Kent M. Pitman)
|
||||
|
||||
Version 0.5.1
|
||||
2003-03-27
|
||||
Removed compiler macro
|
||||
|
||||
Version 0.5.0
|
||||
2003-03-27
|
||||
Lexer, parser, and converter mostly re-written to reduce consing and increase speed
|
||||
Get rid of FIX-POS in lexer and parser, "ism" flags are handled after parsing now
|
||||
Smaller test suite (again) due to literal embedding of line breaks
|
||||
Seperate test files for DOS line endings
|
||||
Replaced constant +REGEX-CHAR-CODE-LIMIT+ with special variable *REGEX-CHAR-CODE-LIMIT*
|
||||
|
||||
Version 0.4.1
|
||||
2003-03-19
|
||||
Added compiler macro for SCAN
|
||||
Changed test suite to be nicer to Corman Lisp and ECL (see docs for new syntax)
|
||||
Incorporated visual feedback (dots) in test suite (thanks to JP Massar)
|
||||
Added README file
|
||||
Replaced STRING-LIST-TO-SIMPLE-STRING with a much improved version by JP Massar
|
||||
|
||||
Version 0.4.0
|
||||
2003-02-27
|
||||
Added *USE-BMH-MATCHER*
|
||||
|
||||
Version 0.3.2
|
||||
2003-02-21
|
||||
Added load.lisp
|
||||
Various minor changes for Corman Lisp compatibility (thanks to Karsten Poeck and JP Massar)
|
||||
|
||||
Version 0.3.1
|
||||
2003-01-18
|
||||
Bugfix in CREATE-SCANNER (didn't work if flags were given and arg was a parse-tree)
|
||||
|
||||
Version 0.3.0
|
||||
2003-01-12
|
||||
Added new features to REGEX-REPLACE and REGEX-REPLACE-ALL
|
||||
|
||||
Version 0.2.0
|
||||
2003-01-11
|
||||
Make SPLIT more Perl-compatible, including new keyword parameters
|
||||
|
||||
Version 0.1.4
|
||||
2003-01-10
|
||||
Don't move "^" and "\A" while iterating with DO-SCANS
|
||||
Added link to Debian package
|
||||
|
||||
Version 0.1.3
|
||||
2002-12-25
|
||||
More usable MK:DEFSYSTEM files (courtesy of Hannu Koivisto)
|
||||
Fixed typo in documentation
|
||||
|
||||
Version 0.1.2
|
||||
2002-12-22
|
||||
Added version numbers for Debian packaging
|
||||
Be friendly to case-sensitive ACL images (courtesy of Kevin Rosenberg and Douglas Crosher)
|
||||
"Fixed" two cases where declarations came after docstrings (because of bugs in Corman Lisp and older CMUCL versions)
|
||||
Added #-cormanlisp to hide (INCF (THE FIXNUM POS)) from Corman Lisp
|
||||
Added file doc/benchmarks.2002-12-22.txt
|
||||
|
||||
Version 0.1.1
|
||||
2002-12-21
|
||||
Added asdf system definitions by Marco Baringer
|
||||
Small additions to documentation
|
||||
Correct (Emacs) local variables list in closures.lisp and api.lisp
|
||||
Added this CHANGELOG
|
||||
|
||||
Version 0.1.0
|
||||
2002-12-20
|
||||
Initial release
|
||||
Some files were not shown because too many files have changed in this diff Show more
Loading…
Add table
Add a link
Reference in a new issue