Removed quicklisp
This commit is contained in:
Ian Keane
commit
96c0b3e15c
741 changed files with 42704 additions and 17 deletions
|
|
@ -1,15 +1,6 @@
|
||||||
<<<<<<< HEAD
|
|
||||||
=======
|
|
||||||
#
|
|
||||||
# ~/.bash_profile
|
# ~/.bash_profile
|
||||||
#
|
#
|
||||||
# Get the aliases and functions
|
# Get the aliases and functions
|
||||||
[ -f $HOME/.bashrc ] && . $HOME/.bashrc
|
[ -f $HOME/.bashrc ] && . $HOME/.bashrc
|
||||||
[[ -f ~/.bashrc ]] && . ~/.bashrc
|
[[ -f ~/.bashrc ]] && . ~/.bashrc
|
||||||
|
|
||||||
export XDG_CONFIG_HOME="$HOME/.config"
|
|
||||||
#export DISPLAY=:0
|
|
||||||
export BROWSER=firefox
|
|
||||||
export EDITOR=vim
|
|
||||||
export TERM=screen-256color
|
|
||||||
>>>>>>> 05f5a5326ea758311bda4cc4225cd0ce265b8ec0
|
|
||||||
|
|
|
||||||
18
mpd/mpd.conf
18
mpd/mpd.conf
|
|
@ -1,6 +1,6 @@
|
||||||
db_file "~/.config/mpd/database"
|
db_file "~/.config/mpd/database"
|
||||||
log_file "~/.config/mpd/log"
|
log_file "~/.config/mpd/log"
|
||||||
music_directory "~/Music"
|
music_directory "/mnt/media/music"
|
||||||
playlist_directory "~/.config/mpd/playlists"
|
playlist_directory "~/.config/mpd/playlists"
|
||||||
pid_file "~/.config/mpd/pid"
|
pid_file "~/.config/mpd/pid"
|
||||||
state_file "~/.config/mpd/state"
|
state_file "~/.config/mpd/state"
|
||||||
|
|
@ -15,7 +15,7 @@ max_output_buffer_size "16384"
|
||||||
audio_output {
|
audio_output {
|
||||||
type "alsa"
|
type "alsa"
|
||||||
name "alsa for audio soundcard"
|
name "alsa for audio soundcard"
|
||||||
mixer_type "software"
|
# mixer_type "software"
|
||||||
}
|
}
|
||||||
|
|
||||||
audio_output {
|
audio_output {
|
||||||
|
|
@ -24,3 +24,17 @@ name "toggle_visualizer"
|
||||||
path "/tmp/mpd.fifo"
|
path "/tmp/mpd.fifo"
|
||||||
format "44100:16:2"
|
format "44100:16:2"
|
||||||
}
|
}
|
||||||
|
|
||||||
|
audio_output {
|
||||||
|
type "pulse"
|
||||||
|
name "PulseAudio Output"
|
||||||
|
#server "localhost" # optional
|
||||||
|
#sink "alsa_output" # optional
|
||||||
|
}
|
||||||
|
|
||||||
|
audio_output {
|
||||||
|
type "alsa"
|
||||||
|
name "MPD"
|
||||||
|
device "pulse"
|
||||||
|
mixer_control "Master"
|
||||||
|
}
|
||||||
|
|
|
||||||
|
|
@ -30,7 +30,7 @@ color listfocus_unread yellow default bold
|
||||||
color info red black bold
|
color info red black bold
|
||||||
color article cyan default
|
color article cyan default
|
||||||
|
|
||||||
browser linkhandler
|
# browser linkhandler
|
||||||
macro , open-in-browser
|
macro , open-in-browser
|
||||||
macro t set browser "tsp youtube-dl --add-metadata -ic"; open-in-browser ; set browser linkhandler
|
macro t set browser "tsp youtube-dl --add-metadata -ic"; open-in-browser ; set browser linkhandler
|
||||||
macro a set browser "tsp youtube-dl --add-metadata -xic -f bestaudio/best"; open-in-browser ; set browser linkhandler
|
macro a set browser "tsp youtube-dl --add-metadata -xic -f bestaudio/best"; open-in-browser ; set browser linkhandler
|
||||||
|
|
|
||||||
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.
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.
|
|
@ -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-ppcre-20190521-git/
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
dists/quicklisp/software/cl-project-20190521-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/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/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/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,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,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
|
||||||
|
|
@ -0,0 +1,30 @@
|
||||||
|
# CL-PPCRE - Portable Perl-compatible regular expressions for Common Lisp
|
||||||
|
|
||||||
|
## Abstract
|
||||||
|
|
||||||
|
CL-PPCRE is a portable regular expression library for Common Lisp
|
||||||
|
which has the following features:
|
||||||
|
|
||||||
|
* It is **compatible with Perl** (especially when used in conjunction
|
||||||
|
with [cl-interpol](http://weitz.de/cl-interpol/), to allow
|
||||||
|
compatible parsing of regexp strings).
|
||||||
|
* It is pretty **fast**.
|
||||||
|
* It is **portable** between ANSI-compliant Common Lisp
|
||||||
|
implementations.
|
||||||
|
* It is **thread-safe**.
|
||||||
|
* In addition to specifying regular expressions as strings like in
|
||||||
|
Perl you can also use **S-expressions**.
|
||||||
|
* It comes with a
|
||||||
|
**[BSD-style license](http://www.opensource.org/licenses/bsd-license.php)**
|
||||||
|
so you can basically do with it whatever you want.
|
||||||
|
|
||||||
|
CL-PPCRE has been used successfully in various applications like
|
||||||
|
[BioBike](http://nostoc.stanford.edu/Docs/),
|
||||||
|
[clutu](http://clutu.com/),
|
||||||
|
[LoGS](http://www.hpc.unm.edu/~download/LoGS/),
|
||||||
|
[CafeSpot](http://cafespot.net/),
|
||||||
|
[Eboy](http://www.eboy.com/), or
|
||||||
|
[The Regex Coach](http://weitz.de/regex-coach/).
|
||||||
|
|
||||||
|
Further documentation can be found in `docs/index.html`, or on
|
||||||
|
[the cl-ppcre homepage](https://edicl.github.io/cl-ppcre/).
|
||||||
File diff suppressed because it is too large
Load diff
|
|
@ -0,0 +1,152 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/charmap.lisp,v 1.19 2009/09/17 19:17:30 edi Exp $
|
||||||
|
|
||||||
|
;;; An optimized representation of sets of characters.
|
||||||
|
|
||||||
|
;;; Copyright (c) 2008-2009, 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-ppcre)
|
||||||
|
|
||||||
|
(defstruct (charmap (:constructor make-charmap%))
|
||||||
|
;; a bit vector mapping char codes to "booleans" (1 for set members,
|
||||||
|
;; 0 for others)
|
||||||
|
(vector #*0 :type simple-bit-vector)
|
||||||
|
;; the smallest character code of all characters in the set
|
||||||
|
(start 0 :type fixnum)
|
||||||
|
;; the upper (exclusive) bound of all character codes in the set
|
||||||
|
(end 0 :type fixnum)
|
||||||
|
;; the number of characters in the set, or NIL if this is unknown
|
||||||
|
(count nil :type (or fixnum null))
|
||||||
|
;; whether the charmap actually represents the complement of the set
|
||||||
|
(complementp nil :type boolean))
|
||||||
|
|
||||||
|
;; seems to be necessary for some Lisps like ClozureCL
|
||||||
|
(defmethod make-load-form ((map charmap) &optional environment)
|
||||||
|
(make-load-form-saving-slots map :environment environment))
|
||||||
|
|
||||||
|
(declaim (inline in-charmap-p))
|
||||||
|
(defun in-charmap-p (char charmap)
|
||||||
|
"Tests whether the character CHAR belongs to the set represented by CHARMAP."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (character char) (charmap charmap))
|
||||||
|
(let* ((char-code (char-code char))
|
||||||
|
(char-in-vector-p
|
||||||
|
(let ((charmap-start (charmap-start charmap)))
|
||||||
|
(declare (fixnum charmap-start))
|
||||||
|
(and (<= charmap-start char-code)
|
||||||
|
(< char-code (the fixnum (charmap-end charmap)))
|
||||||
|
(= 1 (sbit (the simple-bit-vector (charmap-vector charmap))
|
||||||
|
(- char-code charmap-start)))))))
|
||||||
|
(cond ((charmap-complementp charmap) (not char-in-vector-p))
|
||||||
|
(t char-in-vector-p))))
|
||||||
|
|
||||||
|
(defun charmap-contents (charmap)
|
||||||
|
"Returns a list of all characters belonging to a character map.
|
||||||
|
Only works for non-complement charmaps."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (charmap charmap))
|
||||||
|
(and (not (charmap-complementp charmap))
|
||||||
|
(loop for code of-type fixnum from (charmap-start charmap) to (charmap-end charmap)
|
||||||
|
for i across (the simple-bit-vector (charmap-vector charmap))
|
||||||
|
when (= i 1)
|
||||||
|
collect (code-char code))))
|
||||||
|
|
||||||
|
(defun make-charmap (start end test-function &optional complementp)
|
||||||
|
"Creates and returns a charmap representing all characters with
|
||||||
|
character codes in the interval [start end) that satisfy
|
||||||
|
TEST-FUNCTION. The COMPLEMENTP slot of the charmap is set to the
|
||||||
|
value of the optional argument, but this argument doesn't have an
|
||||||
|
effect on how TEST-FUNCTION is used."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (fixnum start end))
|
||||||
|
(let ((vector (make-array (- end start) :element-type 'bit))
|
||||||
|
(count 0))
|
||||||
|
(declare (fixnum count))
|
||||||
|
(loop for code from start below end
|
||||||
|
for char = (code-char code)
|
||||||
|
for index from 0
|
||||||
|
when char do
|
||||||
|
(incf count)
|
||||||
|
(setf (sbit vector index) (if (funcall test-function char) 1 0)))
|
||||||
|
(make-charmap% :vector vector
|
||||||
|
:start start
|
||||||
|
:end end
|
||||||
|
;; we don't know for sure if COMPLEMENTP is true as
|
||||||
|
;; there isn't a necessary a character for each
|
||||||
|
;; integer below *REGEX-CHAR-CODE-LIMIT*
|
||||||
|
:count (and (not complementp) count)
|
||||||
|
;; make sure it's boolean
|
||||||
|
:complementp (not (not complementp)))))
|
||||||
|
|
||||||
|
(defun create-charmap-from-test-function (test-function start end)
|
||||||
|
"Creates and returns a charmap representing all characters with
|
||||||
|
character codes between START and END which satisfy TEST-FUNCTION.
|
||||||
|
Tries to find the smallest interval which is necessary to represent
|
||||||
|
the character set and uses the complement representation if that
|
||||||
|
helps."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let (start-in end-in start-out end-out)
|
||||||
|
;; determine the smallest intervals containing the set and its
|
||||||
|
;; complement, [start-in, end-in) and [start-out, end-out) - first
|
||||||
|
;; the lower bound
|
||||||
|
(loop for code from start below end
|
||||||
|
for char = (code-char code)
|
||||||
|
until (and start-in start-out)
|
||||||
|
when (and char
|
||||||
|
(not start-in)
|
||||||
|
(funcall test-function char))
|
||||||
|
do (setq start-in code)
|
||||||
|
when (and char
|
||||||
|
(not start-out)
|
||||||
|
(not (funcall test-function char)))
|
||||||
|
do (setq start-out code))
|
||||||
|
(unless start-in
|
||||||
|
;; no character satisfied the test, so return a "pseudo" charmap
|
||||||
|
;; where IN-CHARMAP-P is always false
|
||||||
|
(return-from create-charmap-from-test-function
|
||||||
|
(make-charmap% :count 0)))
|
||||||
|
(unless start-out
|
||||||
|
;; no character failed the test, so return a "pseudo" charmap
|
||||||
|
;; where IN-CHARMAP-P is always true
|
||||||
|
(return-from create-charmap-from-test-function
|
||||||
|
(make-charmap% :complementp t)))
|
||||||
|
;; now determine upper bound
|
||||||
|
(loop for code from (1- end) downto start
|
||||||
|
for char = (code-char code)
|
||||||
|
until (and end-in end-out)
|
||||||
|
when (and char
|
||||||
|
(not end-in)
|
||||||
|
(funcall test-function char))
|
||||||
|
do (setq end-in (1+ code))
|
||||||
|
when (and char
|
||||||
|
(not end-out)
|
||||||
|
(not (funcall test-function char)))
|
||||||
|
do (setq end-out (1+ code)))
|
||||||
|
;; use the smaller interval
|
||||||
|
(cond ((<= (- end-in start-in) (- end-out start-out))
|
||||||
|
(make-charmap start-in end-in test-function))
|
||||||
|
(t (make-charmap start-out end-out (complement* test-function) t)))))
|
||||||
|
|
@ -0,0 +1,242 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/charset.lisp,v 1.10 2009/09/17 19:17:30 edi Exp $
|
||||||
|
|
||||||
|
;;; A specialized set implementation for characters by Nikodemus Siivola.
|
||||||
|
|
||||||
|
;;; Copyright (c) 2008, Nikodemus Siivola. All rights reserved.
|
||||||
|
;;; Copyright (c) 2008-2009, 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-ppcre)
|
||||||
|
|
||||||
|
(defconstant +probe-depth+ 3
|
||||||
|
"Maximum number of collisions \(for any element) we accept before we
|
||||||
|
allocate more storage. This is now fixed, but could be made to vary
|
||||||
|
depending on the size of the storage vector \(e.g. in the range of
|
||||||
|
1-4). Larger probe-depths mean more collisions are tolerated before
|
||||||
|
the table grows, but increase the constant factor.")
|
||||||
|
|
||||||
|
(defun make-char-vector (size)
|
||||||
|
"Returns a vector of size SIZE to hold characters. All elements are
|
||||||
|
initialized to #\Null except for the first one which is initialized to
|
||||||
|
#\?."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (type (integer 2 #.(1- array-total-size-limit)) size))
|
||||||
|
;; since #\Null always hashes to 0, store something else there
|
||||||
|
;; initially, and #\Null everywhere else
|
||||||
|
(let ((result (make-array size
|
||||||
|
:element-type #-:lispworks 'character #+:lispworks 'lw:simple-char
|
||||||
|
:initial-element (code-char 0))))
|
||||||
|
(setf (char result 0) #\?)
|
||||||
|
result))
|
||||||
|
|
||||||
|
(defstruct (charset (:constructor make-charset ()))
|
||||||
|
;; this is set to 0 when we stop hashing and just use a CHAR-CODE
|
||||||
|
;; indexed vector
|
||||||
|
(depth +probe-depth+ :type fixnum)
|
||||||
|
;; the number of characters in this set
|
||||||
|
(count 0 :type fixnum)
|
||||||
|
;; the storage vector
|
||||||
|
(vector (make-char-vector 12) :type (simple-array character (*))))
|
||||||
|
|
||||||
|
;; seems to be necessary for some Lisps like ClozureCL
|
||||||
|
(defmethod make-load-form ((set charset) &optional environment)
|
||||||
|
(make-load-form-saving-slots set :environment environment))
|
||||||
|
|
||||||
|
(declaim (inline mix))
|
||||||
|
(defun mix (code hash)
|
||||||
|
"Given a character code CODE and a hash code HASH, computes and
|
||||||
|
returns the \"next\" hash code. See comments below."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; mixing the CHAR-CODE back in at each step makes sure that if two
|
||||||
|
;; characters collide (their hashes end up pointing in the same
|
||||||
|
;; storage vector index) on one round, they should (hopefully!) not
|
||||||
|
;; collide on the next
|
||||||
|
(sxhash (logand most-positive-fixnum (+ code hash))))
|
||||||
|
|
||||||
|
(declaim (inline compute-index))
|
||||||
|
(defun compute-index (hash vector)
|
||||||
|
"Computes and returns the index into the vector VECTOR corresponding
|
||||||
|
to the hash code HASH."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(1+ (mod hash (1- (length vector)))))
|
||||||
|
|
||||||
|
(defun in-charset-p (char set)
|
||||||
|
"Checks whether the character CHAR is in the charset SET."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (character char) (charset set))
|
||||||
|
(let ((vector (charset-vector set))
|
||||||
|
(depth (charset-depth set))
|
||||||
|
(code (char-code char)))
|
||||||
|
(declare (fixnum depth))
|
||||||
|
;; as long as the set remains reasonably small, we use non-linear
|
||||||
|
;; hashing - the first hash of any character is its CHAR-CODE, and
|
||||||
|
;; subsequent hashes are computed by MIX above
|
||||||
|
(cond ((or
|
||||||
|
;; depth 0 is special - each char maps only to its code,
|
||||||
|
;; nothing else
|
||||||
|
(zerop depth)
|
||||||
|
;; index 0 is special - only #\Null maps to it, no matter
|
||||||
|
;; what the depth is
|
||||||
|
(zerop code))
|
||||||
|
(eq char (char vector code)))
|
||||||
|
(t
|
||||||
|
;; otherwise hash starts out as the character code, but
|
||||||
|
;; maps to indexes 1-N
|
||||||
|
(let ((hash code))
|
||||||
|
(tagbody
|
||||||
|
:retry
|
||||||
|
(let* ((index (compute-index hash vector))
|
||||||
|
(x (char vector index)))
|
||||||
|
(cond ((eq x (code-char 0))
|
||||||
|
;; empty, no need to probe further
|
||||||
|
(return-from in-charset-p nil))
|
||||||
|
((eq x char)
|
||||||
|
;; got it
|
||||||
|
(return-from in-charset-p t))
|
||||||
|
((zerop (decf depth))
|
||||||
|
;; max probe depth reached, nothing found
|
||||||
|
(return-from in-charset-p nil))
|
||||||
|
(t
|
||||||
|
;; nothing yet, try next place
|
||||||
|
(setf hash (mix code hash))
|
||||||
|
(go :retry))))))))))
|
||||||
|
|
||||||
|
(defun add-to-charset (char set)
|
||||||
|
"Adds the character CHAR to the charset SET, extending SET if
|
||||||
|
necessary. Returns CHAR."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(or (%add-to-charset char set t)
|
||||||
|
(%add-to-charset/expand char set)
|
||||||
|
(error "Oops, this should not happen..."))
|
||||||
|
char)
|
||||||
|
|
||||||
|
(defun %add-to-charset (char set count)
|
||||||
|
"Tries to add the character CHAR to the charset SET without
|
||||||
|
extending it. Returns NIL if this fails. Counts CHAR as new
|
||||||
|
if COUNT is true and it is added to SET."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (character char) (charset set))
|
||||||
|
(let ((vector (charset-vector set))
|
||||||
|
(depth (charset-depth set))
|
||||||
|
(code (char-code char)))
|
||||||
|
(declare (fixnum depth))
|
||||||
|
;; see comments in IN-CHARSET-P for algorithm
|
||||||
|
(cond ((or (zerop depth) (zerop code))
|
||||||
|
(unless (eq char (char vector code))
|
||||||
|
(setf (char vector code) char)
|
||||||
|
(when count
|
||||||
|
(incf (charset-count set))))
|
||||||
|
char)
|
||||||
|
(t
|
||||||
|
(let ((hash code))
|
||||||
|
(tagbody
|
||||||
|
:retry
|
||||||
|
(let* ((index (compute-index hash vector))
|
||||||
|
(x (char vector index)))
|
||||||
|
(cond ((eq x (code-char 0))
|
||||||
|
(setf (char vector index) char)
|
||||||
|
(when count
|
||||||
|
(incf (charset-count set)))
|
||||||
|
(return-from %add-to-charset char))
|
||||||
|
((eq x char)
|
||||||
|
(return-from %add-to-charset char))
|
||||||
|
((zerop (decf depth))
|
||||||
|
;; need to expand the table
|
||||||
|
(return-from %add-to-charset nil))
|
||||||
|
(t
|
||||||
|
(setf hash (mix code hash))
|
||||||
|
(go :retry))))))))))
|
||||||
|
|
||||||
|
(defun %add-to-charset/expand (char set)
|
||||||
|
"Extends the charset SET and then adds the character CHAR to it."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (character char) (charset set))
|
||||||
|
(let* ((old-vector (charset-vector set))
|
||||||
|
(new-size (* 2 (length old-vector))))
|
||||||
|
(tagbody
|
||||||
|
:retry
|
||||||
|
;; when the table grows large (currently over 1/3 of
|
||||||
|
;; CHAR-CODE-LIMIT), we dispense with hashing and just allocate a
|
||||||
|
;; storage vector with space for all characters, so that each
|
||||||
|
;; character always uses only the CHAR-CODE
|
||||||
|
(multiple-value-bind (new-depth new-vector)
|
||||||
|
(if (>= new-size #.(truncate char-code-limit 3))
|
||||||
|
(values 0 (make-char-vector char-code-limit))
|
||||||
|
(values +probe-depth+ (make-char-vector new-size)))
|
||||||
|
(setf (charset-depth set) new-depth
|
||||||
|
(charset-vector set) new-vector)
|
||||||
|
(flet ((try-add (x)
|
||||||
|
;; don't count - old characters are already accounted
|
||||||
|
;; for, and might count the new one multiple times as
|
||||||
|
;; well
|
||||||
|
(unless (%add-to-charset x set nil)
|
||||||
|
(assert (not (zerop new-depth)))
|
||||||
|
(setf new-size (* 2 new-size))
|
||||||
|
(go :retry))))
|
||||||
|
(try-add char)
|
||||||
|
(dotimes (i (length old-vector))
|
||||||
|
(let ((x (char old-vector i)))
|
||||||
|
(if (eq x (code-char 0))
|
||||||
|
(when (zerop i)
|
||||||
|
(try-add x))
|
||||||
|
(unless (zerop i)
|
||||||
|
(try-add x))))))))
|
||||||
|
;; added and expanded, /now/ count the new character.
|
||||||
|
(incf (charset-count set))
|
||||||
|
t))
|
||||||
|
|
||||||
|
(defun map-charset (function charset)
|
||||||
|
"Calls FUNCTION with all characters in SET. Returns NIL."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (function function))
|
||||||
|
(let* ((n (charset-count charset))
|
||||||
|
(vector (charset-vector charset))
|
||||||
|
(size (length vector)))
|
||||||
|
;; see comments in IN-CHARSET-P for algorithm
|
||||||
|
(when (eq (code-char 0) (char vector 0))
|
||||||
|
(funcall function (code-char 0))
|
||||||
|
(decf n))
|
||||||
|
(loop for i from 1 below size
|
||||||
|
for char = (char vector i)
|
||||||
|
unless (eq (code-char 0) char) do
|
||||||
|
(funcall function char)
|
||||||
|
;; this early termination test should be worth it when
|
||||||
|
;; mapping across depth 0 charsets.
|
||||||
|
(when (zerop (decf n))
|
||||||
|
(return-from map-charset nil))))
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(defun create-charset-from-test-function (test-function start end)
|
||||||
|
"Creates and returns a charset representing all characters with
|
||||||
|
character codes between START and END which satisfy TEST-FUNCTION."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(loop with charset = (make-charset)
|
||||||
|
for code from start below end
|
||||||
|
for char = (code-char code)
|
||||||
|
when (and char (funcall test-function char))
|
||||||
|
do (add-to-charset char charset)
|
||||||
|
finally (return charset)))
|
||||||
|
|
@ -0,0 +1,98 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/chartest.lisp,v 1.5 2009/09/17 19:17:30 edi Exp $
|
||||||
|
|
||||||
|
;;; Copyright (c) 2008-2009, 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-ppcre)
|
||||||
|
|
||||||
|
(defun create-hash-table-from-test-function (test-function start end)
|
||||||
|
"Creates and returns a hash table representing all characters with
|
||||||
|
character codes between START and END which satisfy TEST-FUNCTION."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(loop with hash-table = (make-hash-table)
|
||||||
|
for code from start below end
|
||||||
|
for char = (code-char code)
|
||||||
|
when (and char (funcall test-function char))
|
||||||
|
do (setf (gethash char hash-table) t)
|
||||||
|
finally (return hash-table)))
|
||||||
|
|
||||||
|
(defun create-optimized-test-function (test-function &key
|
||||||
|
(start 0)
|
||||||
|
(end *regex-char-code-limit*)
|
||||||
|
(kind *optimize-char-classes*))
|
||||||
|
"Given a unary test function which is applicable to characters
|
||||||
|
returns a function which yields the same boolean results for all
|
||||||
|
characters with character codes from START to \(excluding) END. If
|
||||||
|
KIND is NIL, TEST-FUNCTION will simply be returned. Otherwise, KIND
|
||||||
|
should be one of:
|
||||||
|
|
||||||
|
* :HASH-TABLE - builds a hash table representing all characters which
|
||||||
|
satisfy the test and returns a closure which checks if
|
||||||
|
a character is in that hash table
|
||||||
|
|
||||||
|
* :CHARSET - instead of a hash table uses a \"charset\" which is a
|
||||||
|
data structure using non-linear hashing and optimized to
|
||||||
|
represent \(sparse) sets of characters in a fast and
|
||||||
|
space-efficient way \(contributed by Nikodemus Siivola)
|
||||||
|
|
||||||
|
* :CHARMAP - instead of a hash table uses a bit vector to represent
|
||||||
|
the set of characters
|
||||||
|
|
||||||
|
You can also use :HASH-TABLE* or :CHARSET* which are like :HASH-TABLE
|
||||||
|
and :CHARSET but use the complement of the set if the set contains
|
||||||
|
more than half of all characters between START and END. This saves
|
||||||
|
space but needs an additional pass across all characters to create the
|
||||||
|
data structure. There is no corresponding :CHARMAP* kind as the bit
|
||||||
|
vectors are already created to cover the smallest possible interval
|
||||||
|
which contains either the set or its complement."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(ecase kind
|
||||||
|
((nil) test-function)
|
||||||
|
(:charmap
|
||||||
|
(let ((charmap (create-charmap-from-test-function test-function start end)))
|
||||||
|
(lambda (char)
|
||||||
|
(in-charmap-p char charmap))))
|
||||||
|
((:charset :charset*)
|
||||||
|
(let ((charset (create-charset-from-test-function test-function start end)))
|
||||||
|
(cond ((or (eq kind :charset)
|
||||||
|
(<= (charset-count charset) (ceiling (- end start) 2)))
|
||||||
|
(lambda (char)
|
||||||
|
(in-charset-p char charset)))
|
||||||
|
(t (setq charset (create-charset-from-test-function (complement* test-function)
|
||||||
|
start end))
|
||||||
|
(lambda (char)
|
||||||
|
(not (in-charset-p char charset)))))))
|
||||||
|
((:hash-table :hash-table*)
|
||||||
|
(let ((hash-table (create-hash-table-from-test-function test-function start end)))
|
||||||
|
(cond ((or (eq kind :hash-table)
|
||||||
|
(<= (hash-table-count hash-table) (ceiling (- end start) 2)))
|
||||||
|
(lambda (char)
|
||||||
|
(gethash char hash-table)))
|
||||||
|
(t (setq hash-table (create-hash-table-from-test-function (complement* test-function)
|
||||||
|
start end))
|
||||||
|
(lambda (char)
|
||||||
|
(not (gethash char hash-table)))))))))
|
||||||
|
|
@ -0,0 +1,64 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre-unicode.asd,v 1.15 2009/09/17 19:17:30 edi Exp $
|
||||||
|
|
||||||
|
;;; This ASDF system definition was kindly provided by Marco Baringer.
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre-unicode-asd
|
||||||
|
(:use :cl :asdf))
|
||||||
|
|
||||||
|
(in-package :cl-ppcre-unicode-asd)
|
||||||
|
|
||||||
|
(defsystem :cl-ppcre-unicode
|
||||||
|
:description "Perl-compatible regular expression library (Unicode)"
|
||||||
|
:author "Dr. Edi Weitz"
|
||||||
|
:license "BSD"
|
||||||
|
:components ((:module "cl-ppcre-unicode"
|
||||||
|
:serial t
|
||||||
|
:components ((:file "packages")
|
||||||
|
(:file "resolver"))))
|
||||||
|
:depends-on (:cl-ppcre :cl-unicode))
|
||||||
|
|
||||||
|
(defsystem :cl-ppcre-unicode-test
|
||||||
|
:description "Perl-compatible regular expression library tests (Unicode)"
|
||||||
|
:author "Dr. Edi Weitz"
|
||||||
|
:license "BSD"
|
||||||
|
:depends-on (:cl-ppcre-unicode :cl-ppcre-test)
|
||||||
|
:components ((:module "test"
|
||||||
|
:serial t
|
||||||
|
:components ((:file "unicode-tests")))))
|
||||||
|
|
||||||
|
(defmethod perform ((o test-op) (c (eql (find-system :cl-ppcre-unicode))))
|
||||||
|
;; we must load CL-PPCRE explicitly so that the CL-PPCRE-TEST system
|
||||||
|
;; will be found
|
||||||
|
(operate 'load-op :cl-ppcre)
|
||||||
|
(operate 'load-op :cl-ppcre-unicode-test)
|
||||||
|
(funcall (intern (symbol-name :run-all-tests) (find-package :cl-ppcre-test))
|
||||||
|
:more-tests (intern (symbol-name :unicode-test) (find-package :cl-ppcre-test))))
|
||||||
|
|
@ -0,0 +1,38 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre-unicode/packages.lisp,v 1.3 2009/09/17 19:17:34 edi Exp $
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre-unicode
|
||||||
|
#+:genera
|
||||||
|
(:shadowing-import-from :common-lisp :lambda :string)
|
||||||
|
(:use #-:genera :cl #+:genera :future-common-lisp
|
||||||
|
:cl-ppcre :cl-unicode)
|
||||||
|
(:import-from :cl-ppcre :signal-syntax-error)
|
||||||
|
(:export :unicode-property-resolver))
|
||||||
|
|
@ -0,0 +1,61 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre-unicode/resolver.lisp,v 1.5 2008/07/23 02:14:08 edi Exp $
|
||||||
|
|
||||||
|
;;; Copyright (c) 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-ppcre-unicode)
|
||||||
|
|
||||||
|
(defun unicode-property-resolver (property-name)
|
||||||
|
"A property resolver which understands Unicode properties using
|
||||||
|
CL-UNICODE's PROPERTY-TEST function. This resolver is automatically
|
||||||
|
installed in *PROPERTY-RESOLVER* when the CL-PPCRE-UNICODE system is
|
||||||
|
loaded."
|
||||||
|
(or (property-test property-name :errorp nil)
|
||||||
|
(signal-syntax-error "There is no property named ~S." property-name)))
|
||||||
|
|
||||||
|
(setq *property-resolver* 'unicode-property-resolver)
|
||||||
|
|
||||||
|
(pushnew :cl-ppcre-unicode *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
|
||||||
|
|
||||||
|
(defvar *hyperdoc-base-uri* "http://weitz.de/cl-ppcre/")
|
||||||
|
|
||||||
|
(let ((exported-symbols-alist
|
||||||
|
(loop for symbol being the external-symbols of :cl-ppcre-unicode
|
||||||
|
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,85 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/cl-ppcre.asd,v 1.49 2009/10/28 07:36:15 edi Exp $
|
||||||
|
|
||||||
|
;;; This ASDF system definition was kindly provided by Marco Baringer.
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre-asd
|
||||||
|
(:use :cl :asdf))
|
||||||
|
|
||||||
|
(in-package :cl-ppcre-asd)
|
||||||
|
|
||||||
|
(defsystem :cl-ppcre
|
||||||
|
:version "2.1.1"
|
||||||
|
:description "Perl-compatible regular expression library"
|
||||||
|
:author "Dr. Edi Weitz"
|
||||||
|
:license "BSD"
|
||||||
|
:serial t
|
||||||
|
:components ((:file "packages")
|
||||||
|
(:file "specials")
|
||||||
|
(:file "util")
|
||||||
|
(:file "errors")
|
||||||
|
(:file "charset")
|
||||||
|
(:file "charmap")
|
||||||
|
(:file "chartest")
|
||||||
|
#-:use-acl-regexp2-engine
|
||||||
|
(:file "lexer")
|
||||||
|
#-:use-acl-regexp2-engine
|
||||||
|
(:file "parser")
|
||||||
|
#-:use-acl-regexp2-engine
|
||||||
|
(:file "regex-class")
|
||||||
|
#-:use-acl-regexp2-engine
|
||||||
|
(:file "regex-class-util")
|
||||||
|
#-:use-acl-regexp2-engine
|
||||||
|
(:file "convert")
|
||||||
|
#-:use-acl-regexp2-engine
|
||||||
|
(:file "optimize")
|
||||||
|
#-:use-acl-regexp2-engine
|
||||||
|
(:file "closures")
|
||||||
|
#-:use-acl-regexp2-engine
|
||||||
|
(:file "repetition-closures")
|
||||||
|
#-:use-acl-regexp2-engine
|
||||||
|
(:file "scanner")
|
||||||
|
(:file "api")))
|
||||||
|
|
||||||
|
(defsystem :cl-ppcre-test
|
||||||
|
:description "Perl-compatible regular expression library tests"
|
||||||
|
:author "Dr. Edi Weitz"
|
||||||
|
:license "BSD"
|
||||||
|
:depends-on (:cl-ppcre :flexi-streams)
|
||||||
|
:components ((:module "test"
|
||||||
|
:serial t
|
||||||
|
:components ((:file "packages")
|
||||||
|
(:file "tests")
|
||||||
|
(:file "perl-tests")))))
|
||||||
|
|
||||||
|
(defmethod perform ((o test-op) (c (eql (find-system :cl-ppcre))))
|
||||||
|
(operate 'load-op :cl-ppcre-test)
|
||||||
|
(funcall (intern (symbol-name :run-all-tests) (find-package :cl-ppcre-test))))
|
||||||
|
|
@ -0,0 +1,471 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/closures.lisp,v 1.45 2009/09/17 19:17:30 edi Exp $
|
||||||
|
|
||||||
|
;;; Here we create the closures which together build the final
|
||||||
|
;;; scanner.
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre)
|
||||||
|
|
||||||
|
(declaim (inline *string*= *string*-equal))
|
||||||
|
(defun *string*= (string2 start1 end1 start2 end2)
|
||||||
|
"Like STRING=, i.e. compares the special string *STRING* from START1
|
||||||
|
to END1 with STRING2 from START2 to END2. Note that there's no
|
||||||
|
boundary check - this has to be implemented by the caller."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (fixnum start1 end1 start2 end2))
|
||||||
|
(loop for string1-idx of-type fixnum from start1 below end1
|
||||||
|
for string2-idx of-type fixnum from start2 below end2
|
||||||
|
always (char= (schar *string* string1-idx)
|
||||||
|
(schar string2 string2-idx))))
|
||||||
|
|
||||||
|
(defun *string*-equal (string2 start1 end1 start2 end2)
|
||||||
|
"Like STRING-EQUAL, i.e. compares the special string *STRING* from
|
||||||
|
START1 to END1 with STRING2 from START2 to END2. Note that there's no
|
||||||
|
boundary check - this has to be implemented by the caller."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (fixnum start1 end1 start2 end2))
|
||||||
|
(loop for string1-idx of-type fixnum from start1 below end1
|
||||||
|
for string2-idx of-type fixnum from start2 below end2
|
||||||
|
always (char-equal (schar *string* string1-idx)
|
||||||
|
(schar string2 string2-idx))))
|
||||||
|
|
||||||
|
(defgeneric create-matcher-aux (regex next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Creates a closure which takes one parameter,
|
||||||
|
START-POS, and tests whether REGEX can match *STRING* at START-POS
|
||||||
|
such that the call to NEXT-FN after the match would succeed."))
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((seq seq) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; the closure for a SEQ is a chain of closures for the elements of
|
||||||
|
;; this sequence which call each other in turn; the last closure
|
||||||
|
;; calls NEXT-FN
|
||||||
|
(loop for element in (reverse (elements seq))
|
||||||
|
for curr-matcher = next-fn then next-matcher
|
||||||
|
for next-matcher = (create-matcher-aux element curr-matcher)
|
||||||
|
finally (return next-matcher)))
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((alternation alternation) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; first create closures for all alternations of ALTERNATION
|
||||||
|
(let ((all-matchers (mapcar #'(lambda (choice)
|
||||||
|
(create-matcher-aux choice next-fn))
|
||||||
|
(choices alternation))))
|
||||||
|
;; now create a closure which checks if one of the closures
|
||||||
|
;; created above can succeed
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(loop for matcher in all-matchers
|
||||||
|
thereis (funcall (the function matcher) start-pos)))))
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((register register) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; the position of this REGISTER within the whole regex; we start to
|
||||||
|
;; count at 0
|
||||||
|
(let ((num (num register)))
|
||||||
|
(declare (fixnum num))
|
||||||
|
;; STORE-END-OF-REG is a thin wrapper around NEXT-FN which will
|
||||||
|
;; update the corresponding values of *REGS-START* and *REGS-END*
|
||||||
|
;; after the inner matcher has succeeded
|
||||||
|
(flet ((store-end-of-reg (start-pos)
|
||||||
|
(declare (fixnum start-pos)
|
||||||
|
(function next-fn))
|
||||||
|
(setf (svref *reg-starts* num) (svref *regs-maybe-start* num)
|
||||||
|
(svref *reg-ends* num) start-pos)
|
||||||
|
(funcall next-fn start-pos)))
|
||||||
|
;; the inner matcher is a closure corresponding to the regex
|
||||||
|
;; wrapped by this REGISTER
|
||||||
|
(let ((inner-matcher (create-matcher-aux (regex register)
|
||||||
|
#'store-end-of-reg)))
|
||||||
|
(declare (function inner-matcher))
|
||||||
|
;; here comes the actual closure for REGISTER
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
;; remember the old values of *REGS-START* and friends in
|
||||||
|
;; case we cannot match
|
||||||
|
(let ((old-*reg-starts* (svref *reg-starts* num))
|
||||||
|
(old-*regs-maybe-start* (svref *regs-maybe-start* num))
|
||||||
|
(old-*reg-ends* (svref *reg-ends* num)))
|
||||||
|
;; we cannot use *REGS-START* here because Perl allows
|
||||||
|
;; regular expressions like /(a|\1x)*/
|
||||||
|
(setf (svref *regs-maybe-start* num) start-pos)
|
||||||
|
(let ((next-pos (funcall inner-matcher start-pos)))
|
||||||
|
(unless next-pos
|
||||||
|
;; restore old values on failure
|
||||||
|
(setf (svref *reg-starts* num) old-*reg-starts*
|
||||||
|
(svref *regs-maybe-start* num) old-*regs-maybe-start*
|
||||||
|
(svref *reg-ends* num) old-*reg-ends*))
|
||||||
|
next-pos)))))))
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((lookahead lookahead) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; create a closure which just checks for the inner regex and
|
||||||
|
;; doesn't care about NEXT-FN
|
||||||
|
(let ((test-matcher (create-matcher-aux (regex lookahead) #'identity)))
|
||||||
|
(declare (function next-fn test-matcher))
|
||||||
|
(if (positivep lookahead)
|
||||||
|
;; positive look-ahead: check success of inner regex, then call
|
||||||
|
;; NEXT-FN
|
||||||
|
(lambda (start-pos)
|
||||||
|
(and (funcall test-matcher start-pos)
|
||||||
|
(funcall next-fn start-pos)))
|
||||||
|
;; negative look-ahead: check failure of inner regex, then call
|
||||||
|
;; NEXT-FN
|
||||||
|
(lambda (start-pos)
|
||||||
|
(and (not (funcall test-matcher start-pos))
|
||||||
|
(funcall next-fn start-pos))))))
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((lookbehind lookbehind) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let ((len (len lookbehind))
|
||||||
|
;; create a closure which just checks for the inner regex and
|
||||||
|
;; doesn't care about NEXT-FN
|
||||||
|
(test-matcher (create-matcher-aux (regex lookbehind) #'identity)))
|
||||||
|
(declare (function next-fn test-matcher)
|
||||||
|
(fixnum len))
|
||||||
|
(if (positivep lookbehind)
|
||||||
|
;; positive look-behind: check success of inner regex (if we're
|
||||||
|
;; far enough from the start of *STRING*), then call NEXT-FN
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(and (>= (- start-pos (or *real-start-pos* *start-pos*)) len)
|
||||||
|
(funcall test-matcher (- start-pos len))
|
||||||
|
(funcall next-fn start-pos)))
|
||||||
|
;; negative look-behind: check failure of inner regex (if we're
|
||||||
|
;; far enough from the start of *STRING*), then call NEXT-FN
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(and (or (< (- start-pos (or *real-start-pos* *start-pos*)) len)
|
||||||
|
(not (funcall test-matcher (- start-pos len))))
|
||||||
|
(funcall next-fn start-pos))))))
|
||||||
|
|
||||||
|
(defmacro insert-char-class-tester ((char-class chr-expr) &body body)
|
||||||
|
"Utility macro to replace each occurence of '\(CHAR-CLASS-TEST)
|
||||||
|
within BODY with the correct test (corresponding to CHAR-CLASS)
|
||||||
|
against CHR-EXPR."
|
||||||
|
(with-rebinding (char-class)
|
||||||
|
(with-unique-names (test-function)
|
||||||
|
(flet ((substitute-char-class-tester (new)
|
||||||
|
(subst new '(char-class-test) body
|
||||||
|
:test #'equalp)))
|
||||||
|
`(let ((,test-function (test-function ,char-class)))
|
||||||
|
,@(substitute-char-class-tester
|
||||||
|
`(funcall ,test-function ,chr-expr)))))))
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((char-class char-class) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (function next-fn))
|
||||||
|
;; insert a test against the current character within *STRING*
|
||||||
|
(insert-char-class-tester (char-class (schar *string* start-pos))
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(and (< start-pos *end-pos*)
|
||||||
|
(char-class-test)
|
||||||
|
(funcall next-fn (1+ start-pos))))))
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((str str) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (fixnum *end-string-pos*)
|
||||||
|
(function next-fn)
|
||||||
|
;; this special value is set by CREATE-SCANNER when the
|
||||||
|
;; closures are built
|
||||||
|
(special end-string))
|
||||||
|
(let* ((len (len str))
|
||||||
|
(case-insensitive-p (case-insensitive-p str))
|
||||||
|
(start-of-end-string-p (start-of-end-string-p str))
|
||||||
|
(skip (skip str))
|
||||||
|
(str (str str))
|
||||||
|
(chr (schar str 0))
|
||||||
|
(end-string (and end-string (str end-string)))
|
||||||
|
(end-string-len (if end-string
|
||||||
|
(length end-string)
|
||||||
|
nil)))
|
||||||
|
(declare (fixnum len))
|
||||||
|
(cond ((and start-of-end-string-p case-insensitive-p)
|
||||||
|
;; closure for the first STR which belongs to the constant
|
||||||
|
;; string at the end of the regular expression;
|
||||||
|
;; case-insensitive version
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos end-string-len))
|
||||||
|
(let ((test-end-pos (+ start-pos end-string-len)))
|
||||||
|
(declare (fixnum test-end-pos))
|
||||||
|
;; either we're at *END-STRING-POS* (which means that
|
||||||
|
;; it has already been confirmed that end-string
|
||||||
|
;; starts here) or we really have to test
|
||||||
|
(and (or (= start-pos *end-string-pos*)
|
||||||
|
(and (<= test-end-pos *end-pos*)
|
||||||
|
(*string*-equal end-string start-pos test-end-pos
|
||||||
|
0 end-string-len)))
|
||||||
|
(funcall next-fn (+ start-pos len))))))
|
||||||
|
(start-of-end-string-p
|
||||||
|
;; closure for the first STR which belongs to the constant
|
||||||
|
;; string at the end of the regular expression;
|
||||||
|
;; case-sensitive version
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos end-string-len))
|
||||||
|
(let ((test-end-pos (+ start-pos end-string-len)))
|
||||||
|
(declare (fixnum test-end-pos))
|
||||||
|
;; either we're at *END-STRING-POS* (which means that
|
||||||
|
;; it has already been confirmed that end-string
|
||||||
|
;; starts here) or we really have to test
|
||||||
|
(and (or (= start-pos *end-string-pos*)
|
||||||
|
(and (<= test-end-pos *end-pos*)
|
||||||
|
(*string*= end-string start-pos test-end-pos
|
||||||
|
0 end-string-len)))
|
||||||
|
(funcall next-fn (+ start-pos len))))))
|
||||||
|
(skip
|
||||||
|
;; a STR which can be skipped because some other function
|
||||||
|
;; has already confirmed that it matches
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(funcall next-fn (+ start-pos len))))
|
||||||
|
((and (= len 1) case-insensitive-p)
|
||||||
|
;; STR represent exactly one character; case-insensitive
|
||||||
|
;; version
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(and (< start-pos *end-pos*)
|
||||||
|
(char-equal (schar *string* start-pos) chr)
|
||||||
|
(funcall next-fn (1+ start-pos)))))
|
||||||
|
((= len 1)
|
||||||
|
;; STR represent exactly one character; case-sensitive
|
||||||
|
;; version
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(and (< start-pos *end-pos*)
|
||||||
|
(char= (schar *string* start-pos) chr)
|
||||||
|
(funcall next-fn (1+ start-pos)))))
|
||||||
|
(case-insensitive-p
|
||||||
|
;; general case, case-insensitive version
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(let ((next-pos (+ start-pos len)))
|
||||||
|
(declare (fixnum next-pos))
|
||||||
|
(and (<= next-pos *end-pos*)
|
||||||
|
(*string*-equal str start-pos next-pos 0 len)
|
||||||
|
(funcall next-fn next-pos)))))
|
||||||
|
(t
|
||||||
|
;; general case, case-sensitive version
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(let ((next-pos (+ start-pos len)))
|
||||||
|
(declare (fixnum next-pos))
|
||||||
|
(and (<= next-pos *end-pos*)
|
||||||
|
(*string*= str start-pos next-pos 0 len)
|
||||||
|
(funcall next-fn next-pos))))))))
|
||||||
|
|
||||||
|
(declaim (inline word-boundary-p))
|
||||||
|
(defun word-boundary-p (start-pos)
|
||||||
|
"Check whether START-POS is a word-boundary within *STRING*."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(let ((1-start-pos (1- start-pos))
|
||||||
|
(*start-pos* (or *real-start-pos* *start-pos*)))
|
||||||
|
;; either the character before START-POS is a word-constituent and
|
||||||
|
;; the character at START-POS isn't...
|
||||||
|
(or (and (or (= start-pos *end-pos*)
|
||||||
|
(and (< start-pos *end-pos*)
|
||||||
|
(not (word-char-p (schar *string* start-pos)))))
|
||||||
|
(and (< 1-start-pos *end-pos*)
|
||||||
|
(<= *start-pos* 1-start-pos)
|
||||||
|
(word-char-p (schar *string* 1-start-pos))))
|
||||||
|
;; ...or vice versa
|
||||||
|
(and (or (= start-pos *start-pos*)
|
||||||
|
(and (< 1-start-pos *end-pos*)
|
||||||
|
(<= *start-pos* 1-start-pos)
|
||||||
|
(not (word-char-p (schar *string* 1-start-pos)))))
|
||||||
|
(and (< start-pos *end-pos*)
|
||||||
|
(word-char-p (schar *string* start-pos)))))))
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((word-boundary word-boundary) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (function next-fn))
|
||||||
|
(if (negatedp word-boundary)
|
||||||
|
(lambda (start-pos)
|
||||||
|
(and (not (word-boundary-p start-pos))
|
||||||
|
(funcall next-fn start-pos)))
|
||||||
|
(lambda (start-pos)
|
||||||
|
(and (word-boundary-p start-pos)
|
||||||
|
(funcall next-fn start-pos)))))
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((everything everything) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (function next-fn))
|
||||||
|
(if (single-line-p everything)
|
||||||
|
;; closure for single-line-mode: we really match everything, so we
|
||||||
|
;; just advance the index into *STRING* by one and carry on
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(and (< start-pos *end-pos*)
|
||||||
|
(funcall next-fn (1+ start-pos))))
|
||||||
|
;; not single-line-mode, so we have to make sure we don't match
|
||||||
|
;; #\Newline
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(and (< start-pos *end-pos*)
|
||||||
|
(char/= (schar *string* start-pos) #\Newline)
|
||||||
|
(funcall next-fn (1+ start-pos))))))
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((anchor anchor) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (function next-fn))
|
||||||
|
(let ((startp (startp anchor))
|
||||||
|
(multi-line-p (multi-line-p anchor)))
|
||||||
|
(cond ((no-newline-p anchor)
|
||||||
|
;; this must be an end-anchor and it must be modeless, so
|
||||||
|
;; we just have to check whether START-POS equals
|
||||||
|
;; *END-POS*
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(and (= start-pos *end-pos*)
|
||||||
|
(funcall next-fn start-pos))))
|
||||||
|
((and startp multi-line-p)
|
||||||
|
;; a start-anchor in multi-line-mode: check if we're at
|
||||||
|
;; *START-POS* or if the last character was #\Newline
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(let ((*start-pos* (or *real-start-pos* *start-pos*)))
|
||||||
|
(and (or (= start-pos *start-pos*)
|
||||||
|
(and (<= start-pos *end-pos*)
|
||||||
|
(> start-pos *start-pos*)
|
||||||
|
(char= #\Newline
|
||||||
|
(schar *string* (1- start-pos)))))
|
||||||
|
(funcall next-fn start-pos)))))
|
||||||
|
(startp
|
||||||
|
;; a start-anchor which is not in multi-line-mode, so just
|
||||||
|
;; check whether we're at *START-POS*
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(and (= start-pos (or *real-start-pos* *start-pos*))
|
||||||
|
(funcall next-fn start-pos))))
|
||||||
|
(multi-line-p
|
||||||
|
;; an end-anchor in multi-line-mode: check if we're at
|
||||||
|
;; *END-POS* or if the character we're looking at is
|
||||||
|
;; #\Newline
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(and (or (= start-pos *end-pos*)
|
||||||
|
(and (< start-pos *end-pos*)
|
||||||
|
(char= #\Newline
|
||||||
|
(schar *string* start-pos))))
|
||||||
|
(funcall next-fn start-pos))))
|
||||||
|
(t
|
||||||
|
;; an end-anchor which is not in multi-line-mode, so just
|
||||||
|
;; check if we're at *END-POS* or if we're looking at
|
||||||
|
;; #\Newline and there's nothing behind it
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(and (or (= start-pos *end-pos*)
|
||||||
|
(and (= start-pos (1- *end-pos*))
|
||||||
|
(char= #\Newline
|
||||||
|
(schar *string* start-pos))))
|
||||||
|
(funcall next-fn start-pos)))))))
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((back-reference back-reference) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (function next-fn))
|
||||||
|
;; the position of the corresponding REGISTER within the whole
|
||||||
|
;; regex; we start to count at 0
|
||||||
|
(let ((num (num back-reference)))
|
||||||
|
(if (case-insensitive-p back-reference)
|
||||||
|
;; the case-insensitive version
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(let ((reg-start (svref *reg-starts* num))
|
||||||
|
(reg-end (svref *reg-ends* num)))
|
||||||
|
;; only bother to check if the corresponding REGISTER as
|
||||||
|
;; matched successfully already
|
||||||
|
(and reg-start
|
||||||
|
(let ((next-pos (+ start-pos (- (the fixnum reg-end)
|
||||||
|
(the fixnum reg-start)))))
|
||||||
|
(declare (fixnum next-pos))
|
||||||
|
(and
|
||||||
|
(<= next-pos *end-pos*)
|
||||||
|
(*string*-equal *string* start-pos next-pos
|
||||||
|
reg-start reg-end)
|
||||||
|
(funcall next-fn next-pos))))))
|
||||||
|
;; the case-sensitive version
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(let ((reg-start (svref *reg-starts* num))
|
||||||
|
(reg-end (svref *reg-ends* num)))
|
||||||
|
;; only bother to check if the corresponding REGISTER as
|
||||||
|
;; matched successfully already
|
||||||
|
(and reg-start
|
||||||
|
(let ((next-pos (+ start-pos (- (the fixnum reg-end)
|
||||||
|
(the fixnum reg-start)))))
|
||||||
|
(declare (fixnum next-pos))
|
||||||
|
(and
|
||||||
|
(<= next-pos *end-pos*)
|
||||||
|
(*string*= *string* start-pos next-pos
|
||||||
|
reg-start reg-end)
|
||||||
|
(funcall next-fn next-pos)))))))))
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((branch branch) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let* ((test (test branch))
|
||||||
|
(then-matcher (create-matcher-aux (then-regex branch) next-fn))
|
||||||
|
(else-matcher (create-matcher-aux (else-regex branch) next-fn)))
|
||||||
|
(declare (function then-matcher else-matcher))
|
||||||
|
(cond ((numberp test)
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum test))
|
||||||
|
(if (and (< test (length *reg-starts*))
|
||||||
|
(svref *reg-starts* test))
|
||||||
|
(funcall then-matcher start-pos)
|
||||||
|
(funcall else-matcher start-pos))))
|
||||||
|
(t
|
||||||
|
(let ((test-matcher (create-matcher-aux test #'identity)))
|
||||||
|
(declare (function test-matcher))
|
||||||
|
(lambda (start-pos)
|
||||||
|
(if (funcall test-matcher start-pos)
|
||||||
|
(funcall then-matcher start-pos)
|
||||||
|
(funcall else-matcher start-pos))))))))
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((standalone standalone) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let ((inner-matcher (create-matcher-aux (regex standalone) #'identity)))
|
||||||
|
(declare (function next-fn inner-matcher))
|
||||||
|
(lambda (start-pos)
|
||||||
|
(let ((next-pos (funcall inner-matcher start-pos)))
|
||||||
|
(and next-pos
|
||||||
|
(funcall next-fn next-pos))))))
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((filter filter) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let ((fn (fn filter)))
|
||||||
|
(lambda (start-pos)
|
||||||
|
(let ((next-pos (funcall fn start-pos)))
|
||||||
|
(and next-pos
|
||||||
|
(funcall next-fn next-pos))))))
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((void void) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; optimize away VOIDs: don't create a closure, just return NEXT-FN
|
||||||
|
next-fn)
|
||||||
|
|
@ -0,0 +1,879 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/convert.lisp,v 1.57 2009/09/17 19:17:31 edi Exp $
|
||||||
|
|
||||||
|
;;; Here the parse tree is converted into its internal representation
|
||||||
|
;;; using REGEX objects. At the same time some optimizations are
|
||||||
|
;;; already applied.
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre)
|
||||||
|
|
||||||
|
;;; The flags that represent the "ism" modifiers are always kept
|
||||||
|
;;; together in a three-element list. We use the following macros to
|
||||||
|
;;; access individual elements.
|
||||||
|
|
||||||
|
(defmacro case-insensitive-mode-p (flags)
|
||||||
|
"Accessor macro to extract the first flag out of a three-element flag list."
|
||||||
|
`(first ,flags))
|
||||||
|
|
||||||
|
(defmacro multi-line-mode-p (flags)
|
||||||
|
"Accessor macro to extract the second flag out of a three-element flag list."
|
||||||
|
`(second ,flags))
|
||||||
|
|
||||||
|
(defmacro single-line-mode-p (flags)
|
||||||
|
"Accessor macro to extract the third flag out of a three-element flag list."
|
||||||
|
`(third ,flags))
|
||||||
|
|
||||||
|
(defun set-flag (token)
|
||||||
|
"Reads a flag token and sets or unsets the corresponding entry in
|
||||||
|
the special FLAGS list."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special flags))
|
||||||
|
(case token
|
||||||
|
((:case-insensitive-p)
|
||||||
|
(setf (case-insensitive-mode-p flags) t))
|
||||||
|
((:case-sensitive-p)
|
||||||
|
(setf (case-insensitive-mode-p flags) nil))
|
||||||
|
((:multi-line-mode-p)
|
||||||
|
(setf (multi-line-mode-p flags) t))
|
||||||
|
((:not-multi-line-mode-p)
|
||||||
|
(setf (multi-line-mode-p flags) nil))
|
||||||
|
((:single-line-mode-p)
|
||||||
|
(setf (single-line-mode-p flags) t))
|
||||||
|
((:not-single-line-mode-p)
|
||||||
|
(setf (single-line-mode-p flags) nil))
|
||||||
|
(otherwise
|
||||||
|
(signal-syntax-error "Unknown flag token ~A." token))))
|
||||||
|
|
||||||
|
(defgeneric resolve-property (property)
|
||||||
|
(:documentation "Resolves PROPERTY to a unary character test
|
||||||
|
function. PROPERTY can either be a function designator or it can be a
|
||||||
|
string which is resolved using *PROPERTY-RESOLVER*.")
|
||||||
|
(:method ((property-name string))
|
||||||
|
(funcall *property-resolver* property-name))
|
||||||
|
(:method ((function-name symbol))
|
||||||
|
function-name)
|
||||||
|
(:method ((test-function function))
|
||||||
|
test-function))
|
||||||
|
|
||||||
|
(defun convert-char-class-to-test-function (list invertedp case-insensitive-p)
|
||||||
|
"Combines all items in LIST into test function and returns a
|
||||||
|
logical-OR combination of these functions. Items can be single
|
||||||
|
characters, character ranges like \(:RANGE #\\A #\\E), or special
|
||||||
|
character classes like :DIGIT-CLASS. Does the right thing with
|
||||||
|
respect to case-\(in)sensitivity as specified by the special variable
|
||||||
|
FLAGS."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special flags))
|
||||||
|
(let ((test-functions
|
||||||
|
(loop for item in list
|
||||||
|
collect (cond ((characterp item)
|
||||||
|
;; rebind so closure captures the right one
|
||||||
|
(let ((this-char item))
|
||||||
|
(lambda (char)
|
||||||
|
(declare (character char this-char))
|
||||||
|
(char= char this-char))))
|
||||||
|
((symbolp item)
|
||||||
|
(case item
|
||||||
|
((:digit-class) #'digit-char-p)
|
||||||
|
((:non-digit-class) (complement* #'digit-char-p))
|
||||||
|
((:whitespace-char-class) #'whitespacep)
|
||||||
|
((:non-whitespace-char-class) (complement* #'whitespacep))
|
||||||
|
((:word-char-class) #'word-char-p)
|
||||||
|
((:non-word-char-class) (complement* #'word-char-p))
|
||||||
|
(otherwise
|
||||||
|
(signal-syntax-error "Unknown symbol ~A in character class." item))))
|
||||||
|
((and (consp item)
|
||||||
|
(eq (first item) :property))
|
||||||
|
(resolve-property (second item)))
|
||||||
|
((and (consp item)
|
||||||
|
(eq (first item) :inverted-property))
|
||||||
|
(complement* (resolve-property (second item))))
|
||||||
|
((and (consp item)
|
||||||
|
(eq (first item) :range))
|
||||||
|
(let ((from (second item))
|
||||||
|
(to (third item)))
|
||||||
|
(when (char> from to)
|
||||||
|
(signal-syntax-error "Invalid range from ~S to ~S in char-class." from to))
|
||||||
|
(lambda (char)
|
||||||
|
(declare (character char from to))
|
||||||
|
(char<= from char to))))
|
||||||
|
(t (signal-syntax-error "Unknown item ~A in char-class list." item))))))
|
||||||
|
(unless test-functions
|
||||||
|
(signal-syntax-error "Empty character class."))
|
||||||
|
(cond ((cdr test-functions)
|
||||||
|
(cond ((and invertedp case-insensitive-p)
|
||||||
|
(lambda (char)
|
||||||
|
(declare (character char))
|
||||||
|
(loop with both-case-p = (both-case-p char)
|
||||||
|
with char-down = (if both-case-p (char-downcase char) char)
|
||||||
|
with char-up = (if both-case-p (char-upcase char) nil)
|
||||||
|
for test-function in test-functions
|
||||||
|
never (or (funcall test-function char-down)
|
||||||
|
(and char-up (funcall test-function char-up))))))
|
||||||
|
(case-insensitive-p
|
||||||
|
(lambda (char)
|
||||||
|
(declare (character char))
|
||||||
|
(loop with both-case-p = (both-case-p char)
|
||||||
|
with char-down = (if both-case-p (char-downcase char) char)
|
||||||
|
with char-up = (if both-case-p (char-upcase char) nil)
|
||||||
|
for test-function in test-functions
|
||||||
|
thereis (or (funcall test-function char-down)
|
||||||
|
(and char-up (funcall test-function char-up))))))
|
||||||
|
(invertedp
|
||||||
|
(lambda (char)
|
||||||
|
(loop for test-function in test-functions
|
||||||
|
never (funcall test-function char))))
|
||||||
|
(t
|
||||||
|
(lambda (char)
|
||||||
|
(loop for test-function in test-functions
|
||||||
|
thereis (funcall test-function char))))))
|
||||||
|
;; there's only one test-function
|
||||||
|
(t (let ((test-function (first test-functions)))
|
||||||
|
(cond ((and invertedp case-insensitive-p)
|
||||||
|
(lambda (char)
|
||||||
|
(declare (character char))
|
||||||
|
(not (or (funcall test-function (char-downcase char))
|
||||||
|
(and (both-case-p char)
|
||||||
|
(funcall test-function (char-upcase char)))))))
|
||||||
|
(case-insensitive-p
|
||||||
|
(lambda (char)
|
||||||
|
(declare (character char))
|
||||||
|
(or (funcall test-function (char-downcase char))
|
||||||
|
(and (both-case-p char)
|
||||||
|
(funcall test-function (char-upcase char))))))
|
||||||
|
(invertedp (complement* test-function))
|
||||||
|
(t test-function)))))))
|
||||||
|
|
||||||
|
(defun maybe-split-repetition (regex
|
||||||
|
greedyp
|
||||||
|
minimum
|
||||||
|
maximum
|
||||||
|
min-len
|
||||||
|
length
|
||||||
|
reg-seen)
|
||||||
|
"Splits a REPETITION object into a constant and a varying part if
|
||||||
|
applicable, i.e. something like
|
||||||
|
a{3,} -> a{3}a*
|
||||||
|
The arguments to this function correspond to the REPETITION slots of
|
||||||
|
the same name."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (fixnum minimum)
|
||||||
|
(type (or fixnum null) maximum))
|
||||||
|
;; note the usage of COPY-REGEX here; we can't use the same REGEX
|
||||||
|
;; object in both REPETITIONS because they will have different
|
||||||
|
;; offsets
|
||||||
|
(when maximum
|
||||||
|
(when (zerop maximum)
|
||||||
|
;; trivial case: don't repeat at all
|
||||||
|
(return-from maybe-split-repetition
|
||||||
|
(make-instance 'void)))
|
||||||
|
(when (= 1 minimum maximum)
|
||||||
|
;; another trivial case: "repeat" exactly once
|
||||||
|
(return-from maybe-split-repetition
|
||||||
|
regex)))
|
||||||
|
;; first set up the constant part of the repetition
|
||||||
|
;; maybe that's all we need
|
||||||
|
(let ((constant-repetition (if (plusp minimum)
|
||||||
|
(make-instance 'repetition
|
||||||
|
:regex (copy-regex regex)
|
||||||
|
:greedyp greedyp
|
||||||
|
:minimum minimum
|
||||||
|
:maximum minimum
|
||||||
|
:min-len min-len
|
||||||
|
:len length
|
||||||
|
:contains-register-p reg-seen)
|
||||||
|
;; don't create garbage if minimum is 0
|
||||||
|
nil)))
|
||||||
|
(when (and maximum
|
||||||
|
(= maximum minimum))
|
||||||
|
(return-from maybe-split-repetition
|
||||||
|
;; no varying part needed because min = max
|
||||||
|
constant-repetition))
|
||||||
|
;; now construct the varying part
|
||||||
|
(let ((varying-repetition
|
||||||
|
(make-instance 'repetition
|
||||||
|
:regex regex
|
||||||
|
:greedyp greedyp
|
||||||
|
:minimum 0
|
||||||
|
:maximum (if maximum (- maximum minimum) nil)
|
||||||
|
:min-len min-len
|
||||||
|
:len length
|
||||||
|
:contains-register-p reg-seen)))
|
||||||
|
(cond ((zerop minimum)
|
||||||
|
;; min = 0, no constant part needed
|
||||||
|
varying-repetition)
|
||||||
|
((= 1 minimum)
|
||||||
|
;; min = 1, constant part needs no REPETITION wrapped around
|
||||||
|
(make-instance 'seq
|
||||||
|
:elements (list (copy-regex regex)
|
||||||
|
varying-repetition)))
|
||||||
|
(t
|
||||||
|
;; general case
|
||||||
|
(make-instance 'seq
|
||||||
|
:elements (list constant-repetition
|
||||||
|
varying-repetition)))))))
|
||||||
|
|
||||||
|
;; During the conversion of the parse tree we keep track of the start
|
||||||
|
;; of the parse tree in the special variable STARTS-WITH which'll
|
||||||
|
;; either hold a STR object or an EVERYTHING object. The latter is the
|
||||||
|
;; case if the regex starts with ".*" which implicitly anchors the
|
||||||
|
;; regex at the start (perhaps modulo #\Newline).
|
||||||
|
|
||||||
|
(defun maybe-accumulate (str)
|
||||||
|
"Accumulate STR into the special variable STARTS-WITH if
|
||||||
|
ACCUMULATE-START-P (also special) is true and STARTS-WITH is either
|
||||||
|
NIL or a STR object of the same case mode. Always returns NIL."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special accumulate-start-p starts-with))
|
||||||
|
(declare (ftype (function (t) fixnum) len))
|
||||||
|
(when accumulate-start-p
|
||||||
|
(etypecase starts-with
|
||||||
|
(str
|
||||||
|
;; STARTS-WITH already holds a STR, so we check if we can
|
||||||
|
;; concatenate
|
||||||
|
(cond ((eq (case-insensitive-p starts-with)
|
||||||
|
(case-insensitive-p str))
|
||||||
|
;; we modify STARTS-WITH in place
|
||||||
|
(setf (len starts-with)
|
||||||
|
(+ (len starts-with) (len str)))
|
||||||
|
;; note that we use SLOT-VALUE because the accessor
|
||||||
|
;; STR has a declared FTYPE which doesn't fit here
|
||||||
|
(adjust-array (slot-value starts-with 'str)
|
||||||
|
(len starts-with)
|
||||||
|
:fill-pointer t)
|
||||||
|
(setf (subseq (slot-value starts-with 'str)
|
||||||
|
(- (len starts-with) (len str)))
|
||||||
|
(str str)
|
||||||
|
;; STR objects that are parts of STARTS-WITH
|
||||||
|
;; always have their SKIP slot set to true
|
||||||
|
;; because the SCAN function will take care of
|
||||||
|
;; them, i.e. the matcher can ignore them
|
||||||
|
(skip str) t))
|
||||||
|
(t (setq accumulate-start-p nil))))
|
||||||
|
(null
|
||||||
|
;; STARTS-WITH is still empty, so we create a new STR object
|
||||||
|
(setf starts-with
|
||||||
|
(make-instance 'str
|
||||||
|
:str ""
|
||||||
|
:case-insensitive-p (case-insensitive-p str))
|
||||||
|
;; INITIALIZE-INSTANCE will coerce the STR to a simple
|
||||||
|
;; string, so we have to fill it afterwards
|
||||||
|
(slot-value starts-with 'str)
|
||||||
|
(make-array (len str)
|
||||||
|
:initial-contents (str str)
|
||||||
|
:element-type 'character
|
||||||
|
:fill-pointer t
|
||||||
|
:adjustable t)
|
||||||
|
(len starts-with)
|
||||||
|
(len str)
|
||||||
|
;; see remark about SKIP above
|
||||||
|
(skip str) t))
|
||||||
|
(everything
|
||||||
|
;; STARTS-WITH already holds an EVERYTHING object - we can't
|
||||||
|
;; concatenate
|
||||||
|
(setq accumulate-start-p nil))))
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(declaim (inline convert-aux))
|
||||||
|
(defun convert-aux (parse-tree)
|
||||||
|
"Converts the parse tree PARSE-TREE into a REGEX object and returns
|
||||||
|
it. Will also
|
||||||
|
|
||||||
|
- split and optimize repetitions,
|
||||||
|
- accumulate strings or EVERYTHING objects into the special variable
|
||||||
|
STARTS-WITH,
|
||||||
|
- keep track of all registers seen in the special variable REG-NUM,
|
||||||
|
- keep track of all named registers seen in the special variable REG-NAMES
|
||||||
|
- keep track of the highest backreference seen in the special
|
||||||
|
variable MAX-BACK-REF,
|
||||||
|
- maintain and adher to the currently applicable modifiers in the special
|
||||||
|
variable FLAGS, and
|
||||||
|
- maybe even wash your car..."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(if (consp parse-tree)
|
||||||
|
(convert-compound-parse-tree (first parse-tree) parse-tree)
|
||||||
|
(convert-simple-parse-tree parse-tree)))
|
||||||
|
|
||||||
|
(defgeneric convert-compound-parse-tree (token parse-tree &key)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Helper function for CONVERT-AUX which converts
|
||||||
|
parse trees which are conses and dispatches on TOKEN which is the
|
||||||
|
first element of the parse tree.")
|
||||||
|
(:method ((token t) (parse-tree t) &key)
|
||||||
|
(signal-syntax-error "Unknown token ~A in parse-tree." token)))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :sequence)) parse-tree &key)
|
||||||
|
"The case for parse trees like \(:SEQUENCE {<regex>}*)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(cond ((cddr parse-tree)
|
||||||
|
;; this is essentially like
|
||||||
|
;; (MAPCAR 'CONVERT-AUX (REST PARSE-TREE))
|
||||||
|
;; but we don't cons a new list
|
||||||
|
(loop for parse-tree-rest on (rest parse-tree)
|
||||||
|
while parse-tree-rest
|
||||||
|
do (setf (car parse-tree-rest)
|
||||||
|
(convert-aux (car parse-tree-rest))))
|
||||||
|
(make-instance 'seq :elements (rest parse-tree)))
|
||||||
|
(t (convert-aux (second parse-tree)))))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :group)) parse-tree &key)
|
||||||
|
"The case for parse trees like \(:GROUP {<regex>}*).
|
||||||
|
|
||||||
|
This is a syntactical construct equivalent to :SEQUENCE intended to
|
||||||
|
keep the effect of modifiers local."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special flags))
|
||||||
|
;; make a local copy of FLAGS and shadow the global value while we
|
||||||
|
;; descend into the enclosed regexes
|
||||||
|
(let ((flags (copy-list flags)))
|
||||||
|
(declare (special flags))
|
||||||
|
(cond ((cddr parse-tree)
|
||||||
|
(loop for parse-tree-rest on (rest parse-tree)
|
||||||
|
while parse-tree-rest
|
||||||
|
do (setf (car parse-tree-rest)
|
||||||
|
(convert-aux (car parse-tree-rest))))
|
||||||
|
(make-instance 'seq :elements (rest parse-tree)))
|
||||||
|
(t (convert-aux (second parse-tree))))))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :alternation)) parse-tree &key)
|
||||||
|
"The case for \(:ALTERNATION {<regex>}*)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special accumulate-start-p))
|
||||||
|
;; we must stop accumulating objects into STARTS-WITH once we reach
|
||||||
|
;; an alternation
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
(loop for parse-tree-rest on (rest parse-tree)
|
||||||
|
while parse-tree-rest
|
||||||
|
do (setf (car parse-tree-rest)
|
||||||
|
(convert-aux (car parse-tree-rest))))
|
||||||
|
(make-instance 'alternation :choices (rest parse-tree)))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :branch)) parse-tree &key)
|
||||||
|
"The case for \(:BRANCH <test> <regex>).
|
||||||
|
|
||||||
|
Here, <test> must be look-ahead, look-behind or number; if <regex> is
|
||||||
|
an alternation it must have one or two choices."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special accumulate-start-p))
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
(let* ((test-candidate (second parse-tree))
|
||||||
|
(test (cond ((numberp test-candidate)
|
||||||
|
(when (zerop (the fixnum test-candidate))
|
||||||
|
(signal-syntax-error "Register 0 doesn't exist: ~S." parse-tree))
|
||||||
|
(1- (the fixnum test-candidate)))
|
||||||
|
(t (convert-aux test-candidate))))
|
||||||
|
(alternations (convert-aux (third parse-tree))))
|
||||||
|
(when (and (not (numberp test))
|
||||||
|
(not (typep test 'lookahead))
|
||||||
|
(not (typep test 'lookbehind)))
|
||||||
|
(signal-syntax-error "Branch test must be look-ahead, look-behind or number: ~S." parse-tree))
|
||||||
|
(typecase alternations
|
||||||
|
(alternation
|
||||||
|
(case (length (choices alternations))
|
||||||
|
((0)
|
||||||
|
(signal-syntax-error "No choices in branch: ~S." parse-tree))
|
||||||
|
((1)
|
||||||
|
(make-instance 'branch
|
||||||
|
:test test
|
||||||
|
:then-regex (first
|
||||||
|
(choices alternations))))
|
||||||
|
((2)
|
||||||
|
(make-instance 'branch
|
||||||
|
:test test
|
||||||
|
:then-regex (first
|
||||||
|
(choices alternations))
|
||||||
|
:else-regex (second
|
||||||
|
(choices alternations))))
|
||||||
|
(otherwise
|
||||||
|
(signal-syntax-error "Too much choices in branch: ~S." parse-tree))))
|
||||||
|
(t
|
||||||
|
(make-instance 'branch
|
||||||
|
:test test
|
||||||
|
:then-regex alternations)))))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :positive-lookahead)) parse-tree &key)
|
||||||
|
"The case for \(:POSITIVE-LOOKAHEAD <regex>)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special flags accumulate-start-p))
|
||||||
|
;; keep the effect of modifiers local to the enclosed regex and stop
|
||||||
|
;; accumulating into STARTS-WITH
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
(let ((flags (copy-list flags)))
|
||||||
|
(declare (special flags))
|
||||||
|
(make-instance 'lookahead
|
||||||
|
:regex (convert-aux (second parse-tree))
|
||||||
|
:positivep t)))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :negative-lookahead)) parse-tree &key)
|
||||||
|
"The case for \(:NEGATIVE-LOOKAHEAD <regex>)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; do the same as for positive look-aheads and just switch afterwards
|
||||||
|
(let ((regex (convert-compound-parse-tree :positive-lookahead parse-tree)))
|
||||||
|
(setf (slot-value regex 'positivep) nil)
|
||||||
|
regex))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :positive-lookbehind)) parse-tree &key)
|
||||||
|
"The case for \(:POSITIVE-LOOKBEHIND <regex>)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special flags accumulate-start-p))
|
||||||
|
;; keep the effect of modifiers local to the enclosed regex and stop
|
||||||
|
;; accumulating into STARTS-WITH
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
(let* ((flags (copy-list flags))
|
||||||
|
(regex (convert-aux (second parse-tree)))
|
||||||
|
(len (regex-length regex)))
|
||||||
|
(declare (special flags))
|
||||||
|
;; lookbehind assertions must be of fixed length
|
||||||
|
(unless len
|
||||||
|
(signal-syntax-error "Variable length look-behind not implemented \(yet): ~S." parse-tree))
|
||||||
|
(make-instance 'lookbehind
|
||||||
|
:regex regex
|
||||||
|
:positivep t
|
||||||
|
:len len)))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :negative-lookbehind)) parse-tree &key)
|
||||||
|
"The case for \(:NEGATIVE-LOOKBEHIND <regex>)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; do the same as for positive look-behinds and just switch afterwards
|
||||||
|
(let ((regex (convert-compound-parse-tree :positive-lookbehind parse-tree)))
|
||||||
|
(setf (slot-value regex 'positivep) nil)
|
||||||
|
regex))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :greedy-repetition)) parse-tree &key (greedyp t))
|
||||||
|
"The case for \(:GREEDY-REPETITION|:NON-GREEDY-REPETITION <min> <max> <regex>).
|
||||||
|
|
||||||
|
This function is also used for the non-greedy case in which case it is
|
||||||
|
called with GREEDYP set to NIL as you would expect."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special accumulate-start-p starts-with))
|
||||||
|
;; remember the value of ACCUMULATE-START-P upon entering
|
||||||
|
(let ((local-accumulate-start-p accumulate-start-p))
|
||||||
|
(let ((minimum (second parse-tree))
|
||||||
|
(maximum (third parse-tree)))
|
||||||
|
(declare (fixnum minimum))
|
||||||
|
(declare (type (or null fixnum) maximum))
|
||||||
|
(unless (and maximum
|
||||||
|
(= 1 minimum maximum))
|
||||||
|
;; set ACCUMULATE-START-P to NIL for the rest of
|
||||||
|
;; the conversion because we can't continue to
|
||||||
|
;; accumulate inside as well as after a proper
|
||||||
|
;; repetition
|
||||||
|
(setq accumulate-start-p nil))
|
||||||
|
(let* (reg-seen
|
||||||
|
(regex (convert-aux (fourth parse-tree)))
|
||||||
|
(min-len (regex-min-length regex))
|
||||||
|
(length (regex-length regex)))
|
||||||
|
;; note that this declaration already applies to
|
||||||
|
;; the call to CONVERT-AUX above
|
||||||
|
(declare (special reg-seen))
|
||||||
|
(when (and local-accumulate-start-p
|
||||||
|
(not starts-with)
|
||||||
|
(zerop minimum)
|
||||||
|
(not maximum))
|
||||||
|
;; if this repetition is (equivalent to) ".*"
|
||||||
|
;; and if we're at the start of the regex we
|
||||||
|
;; remember it for ADVANCE-FN (see the SCAN
|
||||||
|
;; function)
|
||||||
|
(setq starts-with (everythingp regex)))
|
||||||
|
(if (or (not reg-seen)
|
||||||
|
(not greedyp)
|
||||||
|
(not length)
|
||||||
|
(zerop length)
|
||||||
|
(and maximum (= minimum maximum)))
|
||||||
|
;; the repetition doesn't enclose a register, or
|
||||||
|
;; it's not greedy, or we can't determine it's
|
||||||
|
;; (inner) length, or the length is zero, or the
|
||||||
|
;; number of repetitions is fixed; in all of
|
||||||
|
;; these cases we don't bother to optimize
|
||||||
|
(maybe-split-repetition regex
|
||||||
|
greedyp
|
||||||
|
minimum
|
||||||
|
maximum
|
||||||
|
min-len
|
||||||
|
length
|
||||||
|
reg-seen)
|
||||||
|
;; otherwise we make a transformation that looks
|
||||||
|
;; roughly like one of
|
||||||
|
;; <regex>* -> (?:<regex'>*<regex>)?
|
||||||
|
;; <regex>+ -> <regex'>*<regex>
|
||||||
|
;; where the trick is that as much as possible
|
||||||
|
;; registers from <regex> are removed in
|
||||||
|
;; <regex'>
|
||||||
|
(let* (reg-seen ; new instance for REMOVE-REGISTERS
|
||||||
|
(remove-registers-p t)
|
||||||
|
(inner-regex (remove-registers regex))
|
||||||
|
(inner-repetition
|
||||||
|
;; this is the "<regex'>" part
|
||||||
|
(maybe-split-repetition inner-regex
|
||||||
|
;; always greedy
|
||||||
|
t
|
||||||
|
;; reduce minimum by 1
|
||||||
|
;; unless it's already 0
|
||||||
|
(if (zerop minimum)
|
||||||
|
0
|
||||||
|
(1- minimum))
|
||||||
|
;; reduce maximum by 1
|
||||||
|
;; unless it's NIL
|
||||||
|
(and maximum
|
||||||
|
(1- maximum))
|
||||||
|
min-len
|
||||||
|
length
|
||||||
|
reg-seen))
|
||||||
|
(inner-seq
|
||||||
|
;; this is the "<regex'>*<regex>" part
|
||||||
|
(make-instance 'seq
|
||||||
|
:elements (list inner-repetition
|
||||||
|
regex))))
|
||||||
|
;; note that this declaration already applies
|
||||||
|
;; to the call to REMOVE-REGISTERS above
|
||||||
|
(declare (special remove-registers-p reg-seen))
|
||||||
|
;; wrap INNER-SEQ with a greedy
|
||||||
|
;; {0,1}-repetition (i.e. "?") if necessary
|
||||||
|
(if (plusp minimum)
|
||||||
|
inner-seq
|
||||||
|
(maybe-split-repetition inner-seq
|
||||||
|
t
|
||||||
|
0
|
||||||
|
1
|
||||||
|
min-len
|
||||||
|
nil
|
||||||
|
t))))))))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :non-greedy-repetition)) parse-tree &key)
|
||||||
|
"The case for \(:NON-GREEDY-REPETITION <min> <max> <regex>)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; just dispatch to the method above with GREEDYP explicitly set to NIL
|
||||||
|
(convert-compound-parse-tree :greedy-repetition parse-tree :greedyp nil))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :register)) parse-tree &key name)
|
||||||
|
"The case for \(:REGISTER <regex>). Also used for named registers
|
||||||
|
when NAME is not NIL."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special flags reg-num reg-names))
|
||||||
|
;; keep the effect of modifiers local to the enclosed regex; also,
|
||||||
|
;; assign the current value of REG-NUM to the corresponding slot of
|
||||||
|
;; the REGISTER object and increase this counter afterwards; for
|
||||||
|
;; named register update REG-NAMES and set the corresponding name
|
||||||
|
;; slot of the REGISTER object too
|
||||||
|
(let ((flags (copy-list flags))
|
||||||
|
(stored-reg-num reg-num))
|
||||||
|
(declare (special flags reg-seen named-reg-seen))
|
||||||
|
(setq reg-seen t)
|
||||||
|
(when name (setq named-reg-seen t))
|
||||||
|
(incf (the fixnum reg-num))
|
||||||
|
(push name reg-names)
|
||||||
|
(make-instance 'register
|
||||||
|
:regex (convert-aux (if name (third parse-tree) (second parse-tree)))
|
||||||
|
:num stored-reg-num
|
||||||
|
:name name)))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :named-register)) parse-tree &key)
|
||||||
|
"The case for \(:NAMED-REGISTER <regex>)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; call the method above and use the :NAME keyword argument
|
||||||
|
(convert-compound-parse-tree :register parse-tree :name (copy-seq (second parse-tree))))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :filter)) parse-tree &key)
|
||||||
|
"The case for \(:FILTER <function> &optional <length>)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special accumulate-start-p))
|
||||||
|
;; stop accumulating into STARTS-WITH
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
(make-instance 'filter
|
||||||
|
:fn (second parse-tree)
|
||||||
|
:len (third parse-tree)))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :standalone)) parse-tree &key)
|
||||||
|
"The case for \(:STANDALONE <regex>)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special flags accumulate-start-p))
|
||||||
|
;; stop accumulating into STARTS-WITH
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
;; keep the effect of modifiers local to the enclosed regex
|
||||||
|
(let ((flags (copy-list flags)))
|
||||||
|
(declare (special flags))
|
||||||
|
(make-instance 'standalone :regex (convert-aux (second parse-tree)))))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :back-reference)) parse-tree &key)
|
||||||
|
"The case for \(:BACK-REFERENCE <number>|<name>)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special flags accumulate-start-p reg-num reg-names max-back-ref))
|
||||||
|
(let* ((backref-name (and (stringp (second parse-tree))
|
||||||
|
(second parse-tree)))
|
||||||
|
(referred-regs
|
||||||
|
(when backref-name
|
||||||
|
;; find which register corresponds to the given name
|
||||||
|
;; we have to deal with case where several registers share
|
||||||
|
;; the same name and collect their respective numbers
|
||||||
|
(loop for name in reg-names
|
||||||
|
for reg-index from 0
|
||||||
|
when (string= name backref-name)
|
||||||
|
;; NOTE: REG-NAMES stores register names in reversed
|
||||||
|
;; order REG-NUM contains number of (any) registers
|
||||||
|
;; seen so far; 1- will be done later
|
||||||
|
collect (- reg-num reg-index))))
|
||||||
|
;; store the register number for the simple case
|
||||||
|
(backref-number (or (first referred-regs) (second parse-tree))))
|
||||||
|
(declare (type (or fixnum null) backref-number))
|
||||||
|
(when (or (not (typep backref-number 'fixnum))
|
||||||
|
(<= backref-number 0))
|
||||||
|
(signal-syntax-error "Illegal back-reference: ~S." parse-tree))
|
||||||
|
;; stop accumulating into STARTS-WITH and increase MAX-BACK-REF if
|
||||||
|
;; necessary
|
||||||
|
(setq accumulate-start-p nil
|
||||||
|
max-back-ref (max (the fixnum max-back-ref)
|
||||||
|
backref-number))
|
||||||
|
(flet ((make-back-ref (backref-number)
|
||||||
|
(make-instance 'back-reference
|
||||||
|
;; we start counting from 0 internally
|
||||||
|
:num (1- backref-number)
|
||||||
|
:case-insensitive-p (case-insensitive-mode-p flags)
|
||||||
|
;; backref-name is NIL or string, safe to copy
|
||||||
|
:name (copy-seq backref-name))))
|
||||||
|
(cond
|
||||||
|
((cdr referred-regs)
|
||||||
|
;; several registers share the same name we will try to match
|
||||||
|
;; any of them, starting with the most recent first
|
||||||
|
;; alternation is used to accomplish matching
|
||||||
|
(make-instance 'alternation
|
||||||
|
:choices (loop
|
||||||
|
for reg-index in referred-regs
|
||||||
|
collect (make-back-ref reg-index))))
|
||||||
|
;; simple case - backref corresponds to only one register
|
||||||
|
(t
|
||||||
|
(make-back-ref backref-number))))))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :regex)) parse-tree &key)
|
||||||
|
"The case for \(:REGEX <string>)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(convert-aux (parse-string (second parse-tree))))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :char-class)) parse-tree &key invertedp)
|
||||||
|
"The case for \(:CHAR-CLASS {<item>}*) where item is one of
|
||||||
|
|
||||||
|
- a character,
|
||||||
|
- a character range: \(:RANGE <char1> <char2>), or
|
||||||
|
- a special char class symbol like :DIGIT-CHAR-CLASS.
|
||||||
|
|
||||||
|
Also used for inverted char classes when INVERTEDP is true."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special flags accumulate-start-p))
|
||||||
|
(let ((test-function
|
||||||
|
(create-optimized-test-function
|
||||||
|
(convert-char-class-to-test-function (rest parse-tree)
|
||||||
|
invertedp
|
||||||
|
(case-insensitive-mode-p flags)))))
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
(make-instance 'char-class :test-function test-function)))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :inverted-char-class)) parse-tree &key)
|
||||||
|
"The case for \(:INVERTED-CHAR-CLASS {<item>}*)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; just dispatch to the "real" method
|
||||||
|
(convert-compound-parse-tree :char-class parse-tree :invertedp t))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :property)) parse-tree &key)
|
||||||
|
"The case for \(:PROPERTY <name>) where <name> is a string."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special accumulate-start-p))
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
(make-instance 'char-class :test-function (resolve-property (second parse-tree))))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :inverted-property)) parse-tree &key)
|
||||||
|
"The case for \(:INVERTED-PROPERTY <name>) where <name> is a string."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special accumulate-start-p))
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
(make-instance 'char-class :test-function (complement* (resolve-property (second parse-tree)))))
|
||||||
|
|
||||||
|
(defmethod convert-compound-parse-tree ((token (eql :flags)) parse-tree &key)
|
||||||
|
"The case for \(:FLAGS {<flag>}*) where flag is a modifier symbol
|
||||||
|
like :CASE-INSENSITIVE-P."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; set/unset the flags corresponding to the symbols
|
||||||
|
;; following :FLAGS
|
||||||
|
(mapc #'set-flag (rest parse-tree))
|
||||||
|
;; we're only interested in the side effect of
|
||||||
|
;; setting/unsetting the flags and turn this syntactical
|
||||||
|
;; construct into a VOID object which'll be optimized
|
||||||
|
;; away when creating the matcher
|
||||||
|
(make-instance 'void))
|
||||||
|
|
||||||
|
(defgeneric convert-simple-parse-tree (parse-tree)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Helper function for CONVERT-AUX which converts
|
||||||
|
parse trees which are atoms.")
|
||||||
|
(:method ((parse-tree (eql :void)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'void))
|
||||||
|
(:method ((parse-tree (eql :word-boundary)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'word-boundary :negatedp nil))
|
||||||
|
(:method ((parse-tree (eql :non-word-boundary)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'word-boundary :negatedp t))
|
||||||
|
(:method ((parse-tree (eql :everything)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special flags accumulate-start-p))
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
(make-instance 'everything :single-line-p (single-line-mode-p flags)))
|
||||||
|
(:method ((parse-tree (eql :digit-class)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special accumulate-start-p))
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
(make-instance 'char-class :test-function #'digit-char-p))
|
||||||
|
(:method ((parse-tree (eql :word-char-class)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special accumulate-start-p))
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
(make-instance 'char-class :test-function #'word-char-p))
|
||||||
|
(:method ((parse-tree (eql :whitespace-char-class)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special accumulate-start-p))
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
(make-instance 'char-class :test-function #'whitespacep))
|
||||||
|
(:method ((parse-tree (eql :non-digit-class)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special accumulate-start-p))
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
(make-instance 'char-class :test-function (complement* #'digit-char-p)))
|
||||||
|
(:method ((parse-tree (eql :non-word-char-class)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special accumulate-start-p))
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
(make-instance 'char-class :test-function (complement* #'word-char-p)))
|
||||||
|
(:method ((parse-tree (eql :non-whitespace-char-class)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special accumulate-start-p))
|
||||||
|
(setq accumulate-start-p nil)
|
||||||
|
(make-instance 'char-class :test-function (complement* #'whitespacep)))
|
||||||
|
(:method ((parse-tree (eql :start-anchor)))
|
||||||
|
;; Perl's "^"
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special flags))
|
||||||
|
(make-instance 'anchor :startp t :multi-line-p (multi-line-mode-p flags)))
|
||||||
|
(:method ((parse-tree (eql :end-anchor)))
|
||||||
|
;; Perl's "$"
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special flags))
|
||||||
|
(make-instance 'anchor :startp nil :multi-line-p (multi-line-mode-p flags)))
|
||||||
|
(:method ((parse-tree (eql :modeless-start-anchor)))
|
||||||
|
;; Perl's "\A"
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'anchor :startp t))
|
||||||
|
(:method ((parse-tree (eql :modeless-end-anchor)))
|
||||||
|
;; Perl's "$\Z"
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'anchor :startp nil))
|
||||||
|
(:method ((parse-tree (eql :modeless-end-anchor-no-newline)))
|
||||||
|
;; Perl's "$\z"
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'anchor :startp nil :no-newline-p t))
|
||||||
|
(:method ((parse-tree (eql :case-insensitive-p)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(set-flag parse-tree)
|
||||||
|
(make-instance 'void))
|
||||||
|
(:method ((parse-tree (eql :case-sensitive-p)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(set-flag parse-tree)
|
||||||
|
(make-instance 'void))
|
||||||
|
(:method ((parse-tree (eql :multi-line-mode-p)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(set-flag parse-tree)
|
||||||
|
(make-instance 'void))
|
||||||
|
(:method ((parse-tree (eql :not-multi-line-mode-p)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(set-flag parse-tree)
|
||||||
|
(make-instance 'void))
|
||||||
|
(:method ((parse-tree (eql :single-line-mode-p)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(set-flag parse-tree)
|
||||||
|
(make-instance 'void))
|
||||||
|
(:method ((parse-tree (eql :not-single-line-mode-p)))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(set-flag parse-tree)
|
||||||
|
(make-instance 'void)))
|
||||||
|
|
||||||
|
(defmethod convert-simple-parse-tree ((parse-tree string))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special flags))
|
||||||
|
;; turn strings into STR objects and try to accumulate into
|
||||||
|
;; STARTS-WITH
|
||||||
|
(let ((str (make-instance 'str
|
||||||
|
:str parse-tree
|
||||||
|
:case-insensitive-p (case-insensitive-mode-p flags))))
|
||||||
|
(maybe-accumulate str)
|
||||||
|
str))
|
||||||
|
|
||||||
|
(defmethod convert-simple-parse-tree ((parse-tree character))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; dispatch to the method for strings
|
||||||
|
(convert-simple-parse-tree (string parse-tree)))
|
||||||
|
|
||||||
|
(defmethod convert-simple-parse-tree (parse-tree)
|
||||||
|
"The default method - check if there's a translation."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let ((translation (and (symbolp parse-tree) (parse-tree-synonym parse-tree))))
|
||||||
|
(if translation
|
||||||
|
(convert-aux (copy-tree translation))
|
||||||
|
(signal-syntax-error "Unknown token ~A in parse tree." parse-tree))))
|
||||||
|
|
||||||
|
(defun convert (parse-tree)
|
||||||
|
"Converts the parse tree PARSE-TREE into an equivalent REGEX object
|
||||||
|
and returns three values: the REGEX object, the number of registers
|
||||||
|
seen and an object the regex starts with which is either a STR object
|
||||||
|
or an EVERYTHING object \(if the regex starts with something like
|
||||||
|
\".*\") or NIL."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; this function basically just initializes the special variables
|
||||||
|
;; and then calls CONVERT-AUX to do all the work
|
||||||
|
(let* ((flags (list nil nil nil))
|
||||||
|
(reg-num 0)
|
||||||
|
reg-names
|
||||||
|
named-reg-seen
|
||||||
|
(accumulate-start-p t)
|
||||||
|
starts-with
|
||||||
|
(max-back-ref 0)
|
||||||
|
(converted-parse-tree (convert-aux parse-tree)))
|
||||||
|
(declare (special flags reg-num reg-names named-reg-seen
|
||||||
|
accumulate-start-p starts-with max-back-ref))
|
||||||
|
;; make sure we don't reference registers which aren't there
|
||||||
|
(when (> (the fixnum max-back-ref)
|
||||||
|
(the fixnum reg-num))
|
||||||
|
(signal-syntax-error "Backreference to register ~A which has not been defined." max-back-ref))
|
||||||
|
(when (typep starts-with 'str)
|
||||||
|
(setf (slot-value starts-with 'str)
|
||||||
|
(coerce (slot-value starts-with 'str)
|
||||||
|
#+:lispworks 'lw:simple-text-string
|
||||||
|
#-:lispworks 'simple-string)))
|
||||||
|
(values converted-parse-tree reg-num starts-with
|
||||||
|
;; we can't simply use *ALLOW-NAMED-REGISTERS*
|
||||||
|
;; since parse-tree syntax ignores it
|
||||||
|
(when named-reg-seen
|
||||||
|
(nreverse reg-names)))))
|
||||||
File diff suppressed because it is too large
Load diff
|
|
@ -0,0 +1,84 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/errors.lisp,v 1.22 2009/09/17 19:17:31 edi Exp $
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre)
|
||||||
|
|
||||||
|
(defvar *syntax-error-string* nil
|
||||||
|
"The string which caused the syntax error.")
|
||||||
|
|
||||||
|
(define-condition ppcre-error (simple-error)
|
||||||
|
()
|
||||||
|
(:documentation "All errors signaled by CL-PPCRE are of
|
||||||
|
this type."))
|
||||||
|
|
||||||
|
(define-condition ppcre-syntax-error (ppcre-error)
|
||||||
|
((string :initarg :string
|
||||||
|
:reader ppcre-syntax-error-string)
|
||||||
|
(pos :initarg :pos
|
||||||
|
:reader ppcre-syntax-error-pos))
|
||||||
|
(:default-initargs
|
||||||
|
:pos nil
|
||||||
|
:string *syntax-error-string*)
|
||||||
|
(:report (lambda (condition stream)
|
||||||
|
(format stream "~?~@[ at position ~A~]~@[ in string ~S~]"
|
||||||
|
(simple-condition-format-control condition)
|
||||||
|
(simple-condition-format-arguments condition)
|
||||||
|
(ppcre-syntax-error-pos condition)
|
||||||
|
(ppcre-syntax-error-string condition))))
|
||||||
|
(:documentation "Signaled if CL-PPCRE's parser encounters an error
|
||||||
|
when trying to parse a regex string or to convert a parse tree into
|
||||||
|
its internal representation."))
|
||||||
|
|
||||||
|
(setf (documentation 'ppcre-syntax-error-string 'function)
|
||||||
|
"Returns the string the parser was parsing when the error was
|
||||||
|
encountered \(or NIL if the error happened while trying to convert a
|
||||||
|
parse tree).")
|
||||||
|
|
||||||
|
(setf (documentation 'ppcre-syntax-error-pos 'function)
|
||||||
|
"Returns the position within the string where the error occurred
|
||||||
|
\(or NIL if the error happened while trying to convert a parse tree")
|
||||||
|
|
||||||
|
(define-condition ppcre-invocation-error (ppcre-error)
|
||||||
|
()
|
||||||
|
(:documentation "Signaled when CL-PPCRE functions are
|
||||||
|
invoked with wrong arguments."))
|
||||||
|
|
||||||
|
(defmacro signal-syntax-error* (pos format-control &rest format-arguments)
|
||||||
|
`(error 'ppcre-syntax-error
|
||||||
|
:pos ,pos
|
||||||
|
:format-control ,format-control
|
||||||
|
:format-arguments (list ,@format-arguments)))
|
||||||
|
|
||||||
|
(defmacro signal-syntax-error (format-control &rest format-arguments)
|
||||||
|
`(signal-syntax-error* nil ,format-control ,@format-arguments))
|
||||||
|
|
||||||
|
(defmacro signal-invocation-error (format-control &rest format-arguments)
|
||||||
|
`(error 'ppcre-invocation-error
|
||||||
|
:format-control ,format-control
|
||||||
|
:format-arguments (list ,@format-arguments)))
|
||||||
|
|
@ -0,0 +1,738 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/lexer.lisp,v 1.35 2009/09/17 19:17:31 edi Exp $
|
||||||
|
|
||||||
|
;;; The lexer's responsibility is to convert the regex string into a
|
||||||
|
;;; sequence of tokens which are in turn consumed by the parser.
|
||||||
|
;;;
|
||||||
|
;;; The lexer is aware of Perl's 'extended mode' and it also 'knows'
|
||||||
|
;;; (with a little help from the parser) how many register groups it
|
||||||
|
;;; has opened so far. (The latter is necessary for interpreting
|
||||||
|
;;; strings like "\\10" correctly.)
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre)
|
||||||
|
|
||||||
|
(declaim (inline map-char-to-special-class))
|
||||||
|
(defun map-char-to-special-char-class (chr)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Maps escaped characters like \"\\d\" to the tokens which represent
|
||||||
|
their associated character classes."
|
||||||
|
(case chr
|
||||||
|
((#\d)
|
||||||
|
:digit-class)
|
||||||
|
((#\D)
|
||||||
|
:non-digit-class)
|
||||||
|
((#\w)
|
||||||
|
:word-char-class)
|
||||||
|
((#\W)
|
||||||
|
:non-word-char-class)
|
||||||
|
((#\s)
|
||||||
|
:whitespace-char-class)
|
||||||
|
((#\S)
|
||||||
|
:non-whitespace-char-class)))
|
||||||
|
|
||||||
|
(declaim (inline make-lexer-internal))
|
||||||
|
(defstruct (lexer (:constructor make-lexer-internal))
|
||||||
|
"LEXER structures are used to hold the regex string which is
|
||||||
|
currently lexed and to keep track of the lexer's state."
|
||||||
|
(str "" :type string :read-only t)
|
||||||
|
(len 0 :type fixnum :read-only t)
|
||||||
|
(reg 0 :type fixnum)
|
||||||
|
(pos 0 :type fixnum)
|
||||||
|
(last-pos nil :type list))
|
||||||
|
|
||||||
|
(defun make-lexer (string)
|
||||||
|
(declare #-:genera (string string))
|
||||||
|
(make-lexer-internal :str (maybe-coerce-to-simple-string string)
|
||||||
|
:len (length string)))
|
||||||
|
|
||||||
|
(declaim (inline end-of-string-p))
|
||||||
|
(defun end-of-string-p (lexer)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Tests whether we're at the end of the regex string."
|
||||||
|
(<= (lexer-len lexer)
|
||||||
|
(lexer-pos lexer)))
|
||||||
|
|
||||||
|
(declaim (inline looking-at-p))
|
||||||
|
(defun looking-at-p (lexer chr)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Tests whether the next character the lexer would see is CHR.
|
||||||
|
Does not respect extended mode."
|
||||||
|
(and (not (end-of-string-p lexer))
|
||||||
|
(char= (schar (lexer-str lexer) (lexer-pos lexer))
|
||||||
|
chr)))
|
||||||
|
|
||||||
|
(declaim (inline next-char-non-extended))
|
||||||
|
(defun next-char-non-extended (lexer)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Returns the next character which is to be examined and updates the
|
||||||
|
POS slot. Does not respect extended mode."
|
||||||
|
(cond ((end-of-string-p lexer) nil)
|
||||||
|
(t (prog1
|
||||||
|
(schar (lexer-str lexer) (lexer-pos lexer))
|
||||||
|
(incf (lexer-pos lexer))))))
|
||||||
|
|
||||||
|
(defun next-char (lexer)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Returns the next character which is to be examined and updates the
|
||||||
|
POS slot. Respects extended mode, i.e. whitespace, comments, and also
|
||||||
|
nested comments are skipped if applicable."
|
||||||
|
(let ((next-char (next-char-non-extended lexer))
|
||||||
|
last-loop-pos)
|
||||||
|
(loop
|
||||||
|
;; remember where we started
|
||||||
|
(setq last-loop-pos (lexer-pos lexer))
|
||||||
|
;; first we look for nested comments like (?#foo)
|
||||||
|
(when (and next-char
|
||||||
|
(char= next-char #\()
|
||||||
|
(looking-at-p lexer #\?))
|
||||||
|
(incf (lexer-pos lexer))
|
||||||
|
(cond ((looking-at-p lexer #\#)
|
||||||
|
;; must be a nested comment - so we have to search for
|
||||||
|
;; the closing parenthesis
|
||||||
|
(let ((error-pos (- (lexer-pos lexer) 2)))
|
||||||
|
(unless
|
||||||
|
;; loop 'til ')' or end of regex string and
|
||||||
|
;; return NIL if ')' wasn't encountered
|
||||||
|
(loop for skip-char = next-char
|
||||||
|
then (next-char-non-extended lexer)
|
||||||
|
while (and skip-char
|
||||||
|
(char/= skip-char #\)))
|
||||||
|
finally (return skip-char))
|
||||||
|
(signal-syntax-error* error-pos "Comment group not closed.")))
|
||||||
|
(setq next-char (next-char-non-extended lexer)))
|
||||||
|
(t
|
||||||
|
;; undo effect of previous INCF if we didn't see a #
|
||||||
|
(decf (lexer-pos lexer)))))
|
||||||
|
(when *extended-mode-p*
|
||||||
|
;; now - if we're in extended mode - we skip whitespace and
|
||||||
|
;; comments; repeat the following loop while we look at
|
||||||
|
;; whitespace or #\#
|
||||||
|
(loop while (and next-char
|
||||||
|
(or (char= next-char #\#)
|
||||||
|
(whitespacep next-char)))
|
||||||
|
do (setq next-char
|
||||||
|
(if (char= next-char #\#)
|
||||||
|
;; if we saw a comment marker skip until
|
||||||
|
;; we're behind #\Newline...
|
||||||
|
(loop for skip-char = next-char
|
||||||
|
then (next-char-non-extended lexer)
|
||||||
|
while (and skip-char
|
||||||
|
(char/= skip-char #\Newline))
|
||||||
|
finally (return (next-char-non-extended lexer)))
|
||||||
|
;; ...otherwise (whitespace) skip until we
|
||||||
|
;; see the next non-whitespace character
|
||||||
|
(loop for skip-char = next-char
|
||||||
|
then (next-char-non-extended lexer)
|
||||||
|
while (and skip-char
|
||||||
|
(whitespacep skip-char))
|
||||||
|
finally (return skip-char))))))
|
||||||
|
;; if the position has moved we have to repeat our tests
|
||||||
|
;; because of cases like /^a (?#xxx) (?#yyy) {3}c/x which
|
||||||
|
;; would be equivalent to /^a{3}c/ in Perl
|
||||||
|
(unless (> (lexer-pos lexer) last-loop-pos)
|
||||||
|
(return next-char)))))
|
||||||
|
|
||||||
|
(declaim (inline fail))
|
||||||
|
(defun fail (lexer)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Moves (LEXER-POS LEXER) back to the last position stored in
|
||||||
|
\(LEXER-LAST-POS LEXER) and pops the LAST-POS stack."
|
||||||
|
(unless (lexer-last-pos lexer)
|
||||||
|
(signal-syntax-error "LAST-POS stack of LEXER ~A is empty." lexer))
|
||||||
|
(setf (lexer-pos lexer) (pop (lexer-last-pos lexer)))
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(defun get-number (lexer &key (radix 10) max-length no-whitespace-p)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Read and consume the number the lexer is currently looking at and
|
||||||
|
return it. Returns NIL if no number could be identified.
|
||||||
|
RADIX is used as in PARSE-INTEGER. If MAX-LENGTH is not NIL we'll read
|
||||||
|
at most the next MAX-LENGTH characters. If NO-WHITESPACE-P is not NIL
|
||||||
|
we don't tolerate whitespace in front of the number."
|
||||||
|
(when (or (end-of-string-p lexer)
|
||||||
|
(and no-whitespace-p
|
||||||
|
(whitespacep (schar (lexer-str lexer) (lexer-pos lexer)))))
|
||||||
|
(return-from get-number nil))
|
||||||
|
(multiple-value-bind (integer new-pos)
|
||||||
|
(parse-integer (lexer-str lexer)
|
||||||
|
:start (lexer-pos lexer)
|
||||||
|
:end (if max-length
|
||||||
|
(let ((end-pos (+ (lexer-pos lexer)
|
||||||
|
(the fixnum max-length)))
|
||||||
|
(lexer-len (lexer-len lexer)))
|
||||||
|
(if (< end-pos lexer-len)
|
||||||
|
end-pos
|
||||||
|
lexer-len))
|
||||||
|
(lexer-len lexer))
|
||||||
|
:radix radix
|
||||||
|
:junk-allowed t)
|
||||||
|
(cond ((and integer (>= (the fixnum integer) 0))
|
||||||
|
(setf (lexer-pos lexer) new-pos)
|
||||||
|
integer)
|
||||||
|
(t nil))))
|
||||||
|
|
||||||
|
(declaim (inline try-number))
|
||||||
|
(defun try-number (lexer &key (radix 10) max-length no-whitespace-p)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Like GET-NUMBER but won't consume anything if no number is seen."
|
||||||
|
;; remember current position
|
||||||
|
(push (lexer-pos lexer) (lexer-last-pos lexer))
|
||||||
|
(let ((number (get-number lexer
|
||||||
|
:radix radix
|
||||||
|
:max-length max-length
|
||||||
|
:no-whitespace-p no-whitespace-p)))
|
||||||
|
(or number (fail lexer))))
|
||||||
|
|
||||||
|
(declaim (inline make-char-from-code))
|
||||||
|
(defun make-char-from-code (number error-pos)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Create character from char-code NUMBER. NUMBER can be NIL
|
||||||
|
which is interpreted as 0. ERROR-POS is the position where
|
||||||
|
the corresponding number started within the regex string."
|
||||||
|
;; only look at rightmost eight bits in compliance with Perl
|
||||||
|
(let ((code (logand #o377 (the fixnum (or number 0)))))
|
||||||
|
(or (and (< code char-code-limit)
|
||||||
|
(code-char code))
|
||||||
|
(signal-syntax-error* error-pos "No character for hex-code ~X." number))))
|
||||||
|
|
||||||
|
(defun unescape-char (lexer)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Convert the characters\(s) following a backslash into a token
|
||||||
|
which is returned. This function is to be called when the backslash
|
||||||
|
has already been consumed. Special character classes like \\W are
|
||||||
|
handled elsewhere."
|
||||||
|
(when (end-of-string-p lexer)
|
||||||
|
(signal-syntax-error "String ends with backslash."))
|
||||||
|
(let ((chr (next-char-non-extended lexer)))
|
||||||
|
(case chr
|
||||||
|
((#\E)
|
||||||
|
;; if \Q quoting is on this is ignored, otherwise it's just an
|
||||||
|
;; #\E
|
||||||
|
(if *allow-quoting*
|
||||||
|
:void
|
||||||
|
#\E))
|
||||||
|
((#\c)
|
||||||
|
;; \cx means control-x in Perl
|
||||||
|
(let ((next-char (next-char-non-extended lexer)))
|
||||||
|
(unless next-char
|
||||||
|
(signal-syntax-error* (lexer-pos lexer) "Character missing after '\\c'"))
|
||||||
|
(code-char (logxor #x40 (char-code (char-upcase next-char))))))
|
||||||
|
((#\x)
|
||||||
|
;; \x should be followed by a hexadecimal char code,
|
||||||
|
;; two digits or less
|
||||||
|
(let* ((error-pos (lexer-pos lexer))
|
||||||
|
(number (get-number lexer :radix 16 :max-length 2 :no-whitespace-p t)))
|
||||||
|
;; note that it is OK if \x is followed by zero digits
|
||||||
|
(make-char-from-code number error-pos)))
|
||||||
|
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||||
|
;; \x should be followed by an octal char code,
|
||||||
|
;; three digits or less
|
||||||
|
(let* ((error-pos (decf (lexer-pos lexer)))
|
||||||
|
(number (get-number lexer :radix 8 :max-length 3)))
|
||||||
|
(make-char-from-code number error-pos)))
|
||||||
|
;; the following five character names are 'semi-standard'
|
||||||
|
;; according to the CLHS but I'm not aware of any implementation
|
||||||
|
;; that doesn't implement them
|
||||||
|
((#\t)
|
||||||
|
#\Tab)
|
||||||
|
((#\n)
|
||||||
|
#\Newline)
|
||||||
|
((#\r)
|
||||||
|
#\Return)
|
||||||
|
((#\f)
|
||||||
|
#\Page)
|
||||||
|
((#\b)
|
||||||
|
#\Backspace)
|
||||||
|
((#\a)
|
||||||
|
(code-char 7)) ; ASCII bell
|
||||||
|
((#\e)
|
||||||
|
(code-char 27)) ; ASCII escape
|
||||||
|
(otherwise
|
||||||
|
;; all other characters aren't affected by a backslash
|
||||||
|
chr))))
|
||||||
|
|
||||||
|
(defun read-char-property (lexer first-char)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(unless (eql (next-char-non-extended lexer) #\{)
|
||||||
|
(signal-syntax-error* (lexer-pos lexer) "Expected left brace after \\~A." first-char))
|
||||||
|
(let ((name (with-output-to-string (out nil :element-type
|
||||||
|
#+:lispworks 'lw:simple-char #-:lispworks 'character)
|
||||||
|
(loop
|
||||||
|
(let ((char (or (next-char-non-extended lexer)
|
||||||
|
(signal-syntax-error "Unexpected EOF after \\~A{." first-char))))
|
||||||
|
(when (char= char #\})
|
||||||
|
(return))
|
||||||
|
(write-char char out))))))
|
||||||
|
(list (if (char= first-char #\p) :property :inverted-property)
|
||||||
|
name)))
|
||||||
|
|
||||||
|
(defun collect-char-class (lexer)
|
||||||
|
"Reads and consumes characters from regex string until a right
|
||||||
|
bracket is seen. Assembles them into a list \(which is returned) of
|
||||||
|
characters, character ranges, like \(:RANGE #\\A #\\E) for a-e, and
|
||||||
|
tokens representing special character classes."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let ((start-pos (lexer-pos lexer)) ; remember start for error message
|
||||||
|
hyphen-seen
|
||||||
|
last-char
|
||||||
|
list)
|
||||||
|
(flet ((handle-char (c)
|
||||||
|
"Do the right thing with character C depending on whether
|
||||||
|
we're inside a range or not."
|
||||||
|
(cond ((and hyphen-seen last-char)
|
||||||
|
(setf (car list) (list :range last-char c)
|
||||||
|
last-char nil))
|
||||||
|
(t
|
||||||
|
(push c list)
|
||||||
|
(setq last-char c)))
|
||||||
|
(setq hyphen-seen nil)))
|
||||||
|
(loop for first = t then nil
|
||||||
|
for c = (next-char-non-extended lexer)
|
||||||
|
;; leave loop if at end of string
|
||||||
|
while c
|
||||||
|
do (cond
|
||||||
|
((char= c #\\)
|
||||||
|
;; we've seen a backslash
|
||||||
|
(let ((next-char (next-char-non-extended lexer)))
|
||||||
|
(case next-char
|
||||||
|
((#\d #\D #\w #\W #\s #\S)
|
||||||
|
;; a special character class
|
||||||
|
(push (map-char-to-special-char-class next-char) list)
|
||||||
|
;; if the last character was a hyphen
|
||||||
|
;; just collect it literally
|
||||||
|
(when hyphen-seen
|
||||||
|
(push #\- list))
|
||||||
|
;; if the next character is a hyphen do the same
|
||||||
|
(when (looking-at-p lexer #\-)
|
||||||
|
(push #\- list)
|
||||||
|
(incf (lexer-pos lexer)))
|
||||||
|
(setq hyphen-seen nil))
|
||||||
|
((#\P #\p)
|
||||||
|
;; maybe a character property
|
||||||
|
(cond ((null *property-resolver*)
|
||||||
|
(handle-char next-char))
|
||||||
|
(t
|
||||||
|
(push (read-char-property lexer next-char) list)
|
||||||
|
;; if the last character was a hyphen
|
||||||
|
;; just collect it literally
|
||||||
|
(when hyphen-seen
|
||||||
|
(push #\- list))
|
||||||
|
;; if the next character is a hyphen do the same
|
||||||
|
(when (looking-at-p lexer #\-)
|
||||||
|
(push #\- list)
|
||||||
|
(incf (lexer-pos lexer)))
|
||||||
|
(setq hyphen-seen nil))))
|
||||||
|
((#\E)
|
||||||
|
;; if \Q quoting is on we ignore \E,
|
||||||
|
;; otherwise it's just a plain #\E
|
||||||
|
(unless *allow-quoting*
|
||||||
|
(handle-char #\E)))
|
||||||
|
(otherwise
|
||||||
|
;; otherwise unescape the following character(s)
|
||||||
|
(decf (lexer-pos lexer))
|
||||||
|
(handle-char (unescape-char lexer))))))
|
||||||
|
(first
|
||||||
|
;; the first character must not be a right bracket
|
||||||
|
;; and isn't treated specially if it's a hyphen
|
||||||
|
(handle-char c))
|
||||||
|
((char= c #\])
|
||||||
|
;; end of character class
|
||||||
|
;; make sure we collect a pending hyphen
|
||||||
|
(when hyphen-seen
|
||||||
|
(setq hyphen-seen nil)
|
||||||
|
(handle-char #\-))
|
||||||
|
;; reverse the list to preserve the order intended
|
||||||
|
;; by the author of the regex string
|
||||||
|
(return-from collect-char-class (nreverse list)))
|
||||||
|
((and (char= c #\-)
|
||||||
|
last-char
|
||||||
|
(not hyphen-seen))
|
||||||
|
;; if the last character was 'just a character'
|
||||||
|
;; we expect to be in the middle of a range
|
||||||
|
(setq hyphen-seen t))
|
||||||
|
((char= c #\-)
|
||||||
|
;; otherwise this is just an ordinary hyphen
|
||||||
|
(handle-char #\-))
|
||||||
|
(t
|
||||||
|
;; default case - just collect the character
|
||||||
|
(handle-char c))))
|
||||||
|
;; we can only exit the loop normally if we've reached the end
|
||||||
|
;; of the regex string without seeing a right bracket
|
||||||
|
(signal-syntax-error* start-pos "Missing right bracket to close character class."))))
|
||||||
|
|
||||||
|
(defun maybe-parse-flags (lexer)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Reads a sequence of modifiers \(including #\\- to reverse their
|
||||||
|
meaning) and returns a corresponding list of \"flag\" tokens. The
|
||||||
|
\"x\" modifier is treated specially in that it dynamically modifies
|
||||||
|
the behaviour of the lexer itself via the special variable
|
||||||
|
*EXTENDED-MODE-P*."
|
||||||
|
(prog1
|
||||||
|
(loop with set = t
|
||||||
|
for chr = (next-char-non-extended lexer)
|
||||||
|
unless chr
|
||||||
|
do (signal-syntax-error "Unexpected end of string.")
|
||||||
|
while (find chr "-imsx" :test #'char=)
|
||||||
|
;; the first #\- will invert the meaning of all modifiers
|
||||||
|
;; following it
|
||||||
|
if (char= chr #\-)
|
||||||
|
do (setq set nil)
|
||||||
|
else if (char= chr #\x)
|
||||||
|
do (setq *extended-mode-p* set)
|
||||||
|
else collect (if set
|
||||||
|
(case chr
|
||||||
|
((#\i)
|
||||||
|
:case-insensitive-p)
|
||||||
|
((#\m)
|
||||||
|
:multi-line-mode-p)
|
||||||
|
((#\s)
|
||||||
|
:single-line-mode-p))
|
||||||
|
(case chr
|
||||||
|
((#\i)
|
||||||
|
:case-sensitive-p)
|
||||||
|
((#\m)
|
||||||
|
:not-multi-line-mode-p)
|
||||||
|
((#\s)
|
||||||
|
:not-single-line-mode-p))))
|
||||||
|
(decf (lexer-pos lexer))))
|
||||||
|
|
||||||
|
(defun get-quantifier (lexer)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Returns a list of two values (min max) if what the lexer is looking
|
||||||
|
at can be interpreted as a quantifier. Otherwise returns NIL and
|
||||||
|
resets the lexer to its old position."
|
||||||
|
;; remember starting position for FAIL and UNGET-TOKEN functions
|
||||||
|
(push (lexer-pos lexer) (lexer-last-pos lexer))
|
||||||
|
(let ((next-char (next-char lexer)))
|
||||||
|
(case next-char
|
||||||
|
((#\*)
|
||||||
|
;; * (Kleene star): match 0 or more times
|
||||||
|
'(0 nil))
|
||||||
|
((#\+)
|
||||||
|
;; +: match 1 or more times
|
||||||
|
'(1 nil))
|
||||||
|
((#\?)
|
||||||
|
;; ?: match 0 or 1 times
|
||||||
|
'(0 1))
|
||||||
|
((#\{)
|
||||||
|
;; one of
|
||||||
|
;; {n}: match exactly n times
|
||||||
|
;; {n,}: match at least n times
|
||||||
|
;; {n,m}: match at least n but not more than m times
|
||||||
|
;; note that anything not matching one of these patterns will
|
||||||
|
;; be interpreted literally - even whitespace isn't allowed
|
||||||
|
(let ((num1 (get-number lexer :no-whitespace-p t)))
|
||||||
|
(if num1
|
||||||
|
(let ((next-char (next-char-non-extended lexer)))
|
||||||
|
(case next-char
|
||||||
|
((#\,)
|
||||||
|
(let* ((num2 (get-number lexer :no-whitespace-p t))
|
||||||
|
(next-char (next-char-non-extended lexer)))
|
||||||
|
(case next-char
|
||||||
|
((#\})
|
||||||
|
;; this is the case {n,} (NUM2 is NIL) or {n,m}
|
||||||
|
(list num1 num2))
|
||||||
|
(otherwise
|
||||||
|
(fail lexer)))))
|
||||||
|
((#\})
|
||||||
|
;; this is the case {n}
|
||||||
|
(list num1 num1))
|
||||||
|
(otherwise
|
||||||
|
(fail lexer))))
|
||||||
|
;; no number following left curly brace, so we treat it
|
||||||
|
;; like a normal character
|
||||||
|
(fail lexer))))
|
||||||
|
;; cannot be a quantifier
|
||||||
|
(otherwise
|
||||||
|
(fail lexer)))))
|
||||||
|
|
||||||
|
(defun parse-register-name-aux (lexer)
|
||||||
|
"Reads and returns the name in a named register group. It is
|
||||||
|
assumed that the starting #\< character has already been read. The
|
||||||
|
closing #\> will also be consumed."
|
||||||
|
;; we have to look for an ending > character now
|
||||||
|
(let ((end-name (position #\>
|
||||||
|
(lexer-str lexer)
|
||||||
|
:start (lexer-pos lexer)
|
||||||
|
:test #'char=)))
|
||||||
|
(unless end-name
|
||||||
|
;; there has to be > somewhere, syntax error otherwise
|
||||||
|
(signal-syntax-error* (1- (lexer-pos lexer)) "Opening #\< in named group has no closing #\>."))
|
||||||
|
(let ((name (subseq (lexer-str lexer)
|
||||||
|
(lexer-pos lexer)
|
||||||
|
end-name)))
|
||||||
|
(unless (every #'(lambda (char)
|
||||||
|
(or (alphanumericp char)
|
||||||
|
(char= #\- char)))
|
||||||
|
name)
|
||||||
|
;; register name can contain only alphanumeric characters or #\-
|
||||||
|
(signal-syntax-error* (lexer-pos lexer) "Invalid character in named register group."))
|
||||||
|
;; advance lexer beyond "<name>" part
|
||||||
|
(setf (lexer-pos lexer) (1+ end-name))
|
||||||
|
name)))
|
||||||
|
|
||||||
|
(declaim (inline unget-token))
|
||||||
|
(defun unget-token (lexer)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Moves the lexer back to the last position stored in the LAST-POS stack."
|
||||||
|
(if (lexer-last-pos lexer)
|
||||||
|
(setf (lexer-pos lexer)
|
||||||
|
(pop (lexer-last-pos lexer)))
|
||||||
|
(error "No token to unget \(this should not happen)")))
|
||||||
|
|
||||||
|
(defun get-token (lexer)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Returns and consumes the next token from the regex string \(or NIL)."
|
||||||
|
;; remember starting position for UNGET-TOKEN function
|
||||||
|
(push (lexer-pos lexer)
|
||||||
|
(lexer-last-pos lexer))
|
||||||
|
(let ((next-char (next-char lexer)))
|
||||||
|
(cond (next-char
|
||||||
|
(case next-char
|
||||||
|
;; the easy cases first - the following six characters
|
||||||
|
;; always have a special meaning and get translated
|
||||||
|
;; into tokens immediately
|
||||||
|
((#\))
|
||||||
|
:close-paren)
|
||||||
|
((#\|)
|
||||||
|
:vertical-bar)
|
||||||
|
((#\?)
|
||||||
|
:question-mark)
|
||||||
|
((#\.)
|
||||||
|
:everything)
|
||||||
|
((#\^)
|
||||||
|
:start-anchor)
|
||||||
|
((#\$)
|
||||||
|
:end-anchor)
|
||||||
|
((#\+ #\*)
|
||||||
|
;; quantifiers will always be consumend by
|
||||||
|
;; GET-QUANTIFIER, they must not appear here
|
||||||
|
(signal-syntax-error* (1- (lexer-pos lexer)) "Quantifier '~A' not allowed." next-char))
|
||||||
|
((#\{)
|
||||||
|
;; left brace isn't a special character in it's own
|
||||||
|
;; right but we must check if what follows might
|
||||||
|
;; look like a quantifier
|
||||||
|
(let ((this-pos (lexer-pos lexer))
|
||||||
|
(this-last-pos (lexer-last-pos lexer)))
|
||||||
|
(unget-token lexer)
|
||||||
|
(when (get-quantifier lexer)
|
||||||
|
(signal-syntax-error* (car this-last-pos)
|
||||||
|
"Quantifier '~A' not allowed."
|
||||||
|
(subseq (lexer-str lexer)
|
||||||
|
(car this-last-pos)
|
||||||
|
(lexer-pos lexer))))
|
||||||
|
(setf (lexer-pos lexer) this-pos
|
||||||
|
(lexer-last-pos lexer) this-last-pos)
|
||||||
|
next-char))
|
||||||
|
((#\[)
|
||||||
|
;; left bracket always starts a character class
|
||||||
|
(cons (cond ((looking-at-p lexer #\^)
|
||||||
|
(incf (lexer-pos lexer))
|
||||||
|
:inverted-char-class)
|
||||||
|
(t
|
||||||
|
:char-class))
|
||||||
|
(collect-char-class lexer)))
|
||||||
|
((#\\)
|
||||||
|
;; backslash might mean different things so we have
|
||||||
|
;; to peek one char ahead:
|
||||||
|
(let ((next-char (next-char-non-extended lexer)))
|
||||||
|
(case next-char
|
||||||
|
((#\A)
|
||||||
|
:modeless-start-anchor)
|
||||||
|
((#\Z)
|
||||||
|
:modeless-end-anchor)
|
||||||
|
((#\z)
|
||||||
|
:modeless-end-anchor-no-newline)
|
||||||
|
((#\b)
|
||||||
|
:word-boundary)
|
||||||
|
((#\B)
|
||||||
|
:non-word-boundary)
|
||||||
|
((#\k)
|
||||||
|
(cond ((and *allow-named-registers*
|
||||||
|
(looking-at-p lexer #\<))
|
||||||
|
;; back-referencing a named register
|
||||||
|
(incf (lexer-pos lexer))
|
||||||
|
(list :back-reference
|
||||||
|
(parse-register-name-aux lexer)))
|
||||||
|
(t
|
||||||
|
;; false alarm, just unescape \k
|
||||||
|
#\k)))
|
||||||
|
((#\d #\D #\w #\W #\s #\S)
|
||||||
|
;; these will be treated like character classes
|
||||||
|
(map-char-to-special-char-class next-char))
|
||||||
|
((#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||||
|
;; uh, a digit...
|
||||||
|
(let* ((old-pos (decf (lexer-pos lexer)))
|
||||||
|
;; ...so let's get the whole number first
|
||||||
|
(backref-number (get-number lexer)))
|
||||||
|
(declare (fixnum backref-number))
|
||||||
|
(cond ((and (> backref-number (lexer-reg lexer))
|
||||||
|
(<= 10 backref-number))
|
||||||
|
;; \10 and higher are treated as octal
|
||||||
|
;; character codes if we haven't
|
||||||
|
;; opened that much register groups
|
||||||
|
;; yet
|
||||||
|
(setf (lexer-pos lexer) old-pos)
|
||||||
|
;; re-read the number from the old
|
||||||
|
;; position and convert it to its
|
||||||
|
;; corresponding character
|
||||||
|
(make-char-from-code (get-number lexer :radix 8 :max-length 3)
|
||||||
|
old-pos))
|
||||||
|
(t
|
||||||
|
;; otherwise this must refer to a
|
||||||
|
;; backreference
|
||||||
|
(list :back-reference backref-number)))))
|
||||||
|
((#\0)
|
||||||
|
;; this always means an octal character code
|
||||||
|
;; (at most three digits)
|
||||||
|
(let ((old-pos (decf (lexer-pos lexer))))
|
||||||
|
(make-char-from-code (get-number lexer :radix 8 :max-length 3)
|
||||||
|
old-pos)))
|
||||||
|
((#\P #\p)
|
||||||
|
;; might be a named property
|
||||||
|
(cond (*property-resolver* (read-char-property lexer next-char))
|
||||||
|
(t next-char)))
|
||||||
|
(otherwise
|
||||||
|
;; in all other cases just unescape the
|
||||||
|
;; character
|
||||||
|
(decf (lexer-pos lexer))
|
||||||
|
(unescape-char lexer)))))
|
||||||
|
((#\()
|
||||||
|
;; an open parenthesis might mean different things
|
||||||
|
;; depending on what follows...
|
||||||
|
(cond ((looking-at-p lexer #\?)
|
||||||
|
;; this is the case '(?' (and probably more behind)
|
||||||
|
(incf (lexer-pos lexer))
|
||||||
|
;; we have to check for modifiers first
|
||||||
|
;; because a colon might follow
|
||||||
|
(let* ((flags (maybe-parse-flags lexer))
|
||||||
|
(next-char (next-char-non-extended lexer)))
|
||||||
|
;; modifiers are only allowed if a colon
|
||||||
|
;; or a closing parenthesis are following
|
||||||
|
(when (and flags
|
||||||
|
(not (find next-char ":)" :test #'char=)))
|
||||||
|
(signal-syntax-error* (car (lexer-last-pos lexer))
|
||||||
|
"Sequence '~A' not recognized."
|
||||||
|
(subseq (lexer-str lexer)
|
||||||
|
(car (lexer-last-pos lexer))
|
||||||
|
(lexer-pos lexer))))
|
||||||
|
(case next-char
|
||||||
|
((nil)
|
||||||
|
;; syntax error
|
||||||
|
(signal-syntax-error "End of string following '(?'."))
|
||||||
|
((#\))
|
||||||
|
;; an empty group except for the flags
|
||||||
|
;; (if there are any)
|
||||||
|
(or (and flags
|
||||||
|
(cons :flags flags))
|
||||||
|
:void))
|
||||||
|
((#\()
|
||||||
|
;; branch
|
||||||
|
:open-paren-paren)
|
||||||
|
((#\>)
|
||||||
|
;; standalone
|
||||||
|
:open-paren-greater)
|
||||||
|
((#\=)
|
||||||
|
;; positive look-ahead
|
||||||
|
:open-paren-equal)
|
||||||
|
((#\!)
|
||||||
|
;; negative look-ahead
|
||||||
|
:open-paren-exclamation)
|
||||||
|
((#\:)
|
||||||
|
;; non-capturing group - return flags as
|
||||||
|
;; second value
|
||||||
|
(values :open-paren-colon flags))
|
||||||
|
((#\<)
|
||||||
|
;; might be a look-behind assertion or a named group, so
|
||||||
|
;; check next character
|
||||||
|
(let ((next-char (next-char-non-extended lexer)))
|
||||||
|
(cond ((and next-char
|
||||||
|
(alpha-char-p next-char))
|
||||||
|
;; we have encountered a named group
|
||||||
|
;; are we supporting register naming?
|
||||||
|
(unless *allow-named-registers*
|
||||||
|
(signal-syntax-error* (1- (lexer-pos lexer))
|
||||||
|
"Character '~A' may not follow '(?<' (because ~a = NIL)"
|
||||||
|
next-char
|
||||||
|
'*allow-named-registers*))
|
||||||
|
;; put the letter back
|
||||||
|
(decf (lexer-pos lexer))
|
||||||
|
;; named group
|
||||||
|
:open-paren-less-letter)
|
||||||
|
(t
|
||||||
|
(case next-char
|
||||||
|
((#\=)
|
||||||
|
;; positive look-behind
|
||||||
|
:open-paren-less-equal)
|
||||||
|
((#\!)
|
||||||
|
;; negative look-behind
|
||||||
|
:open-paren-less-exclamation)
|
||||||
|
((#\))
|
||||||
|
;; Perl allows "(?<)" and treats
|
||||||
|
;; it like a null string
|
||||||
|
:void)
|
||||||
|
((nil)
|
||||||
|
;; syntax error
|
||||||
|
(signal-syntax-error "End of string following '(?<'."))
|
||||||
|
(t
|
||||||
|
;; also syntax error
|
||||||
|
(signal-syntax-error* (1- (lexer-pos lexer))
|
||||||
|
"Character '~A' may not follow '(?<'."
|
||||||
|
next-char )))))))
|
||||||
|
(otherwise
|
||||||
|
(signal-syntax-error* (1- (lexer-pos lexer))
|
||||||
|
"Character '~A' may not follow '(?'."
|
||||||
|
next-char)))))
|
||||||
|
(t
|
||||||
|
;; if next-char was not #\? (this is within
|
||||||
|
;; the first COND), we've just seen an opening
|
||||||
|
;; parenthesis and leave it like that
|
||||||
|
:open-paren)))
|
||||||
|
(otherwise
|
||||||
|
;; all other characters are their own tokens
|
||||||
|
next-char)))
|
||||||
|
;; we didn't get a character (this if the "else" branch from
|
||||||
|
;; the first IF), so we don't return a token but NIL
|
||||||
|
(t
|
||||||
|
(pop (lexer-last-pos lexer))
|
||||||
|
nil))))
|
||||||
|
|
||||||
|
(declaim (inline start-of-subexpr-p))
|
||||||
|
(defun start-of-subexpr-p (lexer)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Tests whether the next token can start a valid sub-expression, i.e.
|
||||||
|
a stand-alone regex."
|
||||||
|
(let* ((pos (lexer-pos lexer))
|
||||||
|
(next-char (next-char lexer)))
|
||||||
|
(not (or (null next-char)
|
||||||
|
(prog1
|
||||||
|
(member (the character next-char)
|
||||||
|
'(#\) #\|)
|
||||||
|
:test #'char=)
|
||||||
|
(setf (lexer-pos lexer) pos))))))
|
||||||
|
|
@ -0,0 +1,578 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/optimize.lisp,v 1.36 2009/09/17 19:17:31 edi Exp $
|
||||||
|
|
||||||
|
;;; This file contains optimizations which can be applied to converted
|
||||||
|
;;; parse trees.
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre)
|
||||||
|
|
||||||
|
(defgeneric flatten (regex)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Merges adjacent sequences and alternations, i.e. it
|
||||||
|
transforms #<SEQ #<STR \"a\"> #<SEQ #<STR \"b\"> #<STR \"c\">>> to
|
||||||
|
#<SEQ #<STR \"a\"> #<STR \"b\"> #<STR \"c\">>. This is a destructive
|
||||||
|
operation on REGEX."))
|
||||||
|
|
||||||
|
(defmethod flatten ((seq seq))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; this looks more complicated than it is because we modify SEQ in
|
||||||
|
;; place to avoid unnecessary consing
|
||||||
|
(let ((elements-rest (elements seq)))
|
||||||
|
(loop
|
||||||
|
(unless elements-rest
|
||||||
|
(return))
|
||||||
|
(let ((flattened-element (flatten (car elements-rest)))
|
||||||
|
(next-elements-rest (cdr elements-rest)))
|
||||||
|
(cond ((typep flattened-element 'seq)
|
||||||
|
;; FLATTENED-ELEMENT is a SEQ object, so we "splice"
|
||||||
|
;; it into out list of elements
|
||||||
|
(let ((flattened-element-elements
|
||||||
|
(elements flattened-element)))
|
||||||
|
(setf (car elements-rest)
|
||||||
|
(car flattened-element-elements)
|
||||||
|
(cdr elements-rest)
|
||||||
|
(nconc (cdr flattened-element-elements)
|
||||||
|
(cdr elements-rest)))))
|
||||||
|
(t
|
||||||
|
;; otherwise we just replace the current element with
|
||||||
|
;; its flattened counterpart
|
||||||
|
(setf (car elements-rest) flattened-element)))
|
||||||
|
(setq elements-rest next-elements-rest))))
|
||||||
|
(let ((elements (elements seq)))
|
||||||
|
(cond ((cadr elements)
|
||||||
|
seq)
|
||||||
|
((cdr elements)
|
||||||
|
(first elements))
|
||||||
|
(t (make-instance 'void)))))
|
||||||
|
|
||||||
|
(defmethod flatten ((alternation alternation))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; same algorithm as above
|
||||||
|
(let ((choices-rest (choices alternation)))
|
||||||
|
(loop
|
||||||
|
(unless choices-rest
|
||||||
|
(return))
|
||||||
|
(let ((flattened-choice (flatten (car choices-rest)))
|
||||||
|
(next-choices-rest (cdr choices-rest)))
|
||||||
|
(cond ((typep flattened-choice 'alternation)
|
||||||
|
(let ((flattened-choice-choices
|
||||||
|
(choices flattened-choice)))
|
||||||
|
(setf (car choices-rest)
|
||||||
|
(car flattened-choice-choices)
|
||||||
|
(cdr choices-rest)
|
||||||
|
(nconc (cdr flattened-choice-choices)
|
||||||
|
(cdr choices-rest)))))
|
||||||
|
(t
|
||||||
|
(setf (car choices-rest) flattened-choice)))
|
||||||
|
(setq choices-rest next-choices-rest))))
|
||||||
|
(let ((choices (choices alternation)))
|
||||||
|
(cond ((cadr choices)
|
||||||
|
alternation)
|
||||||
|
((cdr choices)
|
||||||
|
(first choices))
|
||||||
|
(t (signal-syntax-error "Encountered alternation without choices.")))))
|
||||||
|
|
||||||
|
(defmethod flatten ((branch branch))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(with-slots (test then-regex else-regex)
|
||||||
|
branch
|
||||||
|
(setq test
|
||||||
|
(if (numberp test)
|
||||||
|
test
|
||||||
|
(flatten test))
|
||||||
|
then-regex (flatten then-regex)
|
||||||
|
else-regex (flatten else-regex))
|
||||||
|
branch))
|
||||||
|
|
||||||
|
(defmethod flatten ((regex regex))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(typecase regex
|
||||||
|
((or repetition register lookahead lookbehind standalone)
|
||||||
|
;; if REGEX contains exactly one inner REGEX object flatten it
|
||||||
|
(setf (regex regex)
|
||||||
|
(flatten (regex regex)))
|
||||||
|
regex)
|
||||||
|
(t
|
||||||
|
;; otherwise (ANCHOR, BACK-REFERENCE, CHAR-CLASS, EVERYTHING,
|
||||||
|
;; LOOKAHEAD, LOOKBEHIND, STR, VOID, FILTER, and WORD-BOUNDARY)
|
||||||
|
;; do nothing
|
||||||
|
regex)))
|
||||||
|
|
||||||
|
(defgeneric gather-strings (regex)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Collects adjacent strings or characters into one
|
||||||
|
string provided they have the same case mode. This is a destructive
|
||||||
|
operation on REGEX."))
|
||||||
|
|
||||||
|
(defmethod gather-strings ((seq seq))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; note that GATHER-STRINGS is to be applied after FLATTEN, i.e. it
|
||||||
|
;; expects SEQ to be flattened already; in particular, SEQ cannot be
|
||||||
|
;; empty and cannot contain embedded SEQ objects
|
||||||
|
(let* ((start-point (cons nil (elements seq)))
|
||||||
|
(curr-point start-point)
|
||||||
|
old-case-mode
|
||||||
|
collector
|
||||||
|
collector-start
|
||||||
|
(collector-length 0)
|
||||||
|
skip)
|
||||||
|
(declare (fixnum collector-length))
|
||||||
|
(loop
|
||||||
|
(let ((elements-rest (cdr curr-point)))
|
||||||
|
(unless elements-rest
|
||||||
|
(return))
|
||||||
|
(let* ((element (car elements-rest))
|
||||||
|
(case-mode (case-mode element old-case-mode)))
|
||||||
|
(cond ((and case-mode
|
||||||
|
(eq case-mode old-case-mode))
|
||||||
|
;; if ELEMENT is a STR and we have collected a STR of
|
||||||
|
;; the same case mode in the last iteration we
|
||||||
|
;; concatenate ELEMENT onto COLLECTOR and remember the
|
||||||
|
;; value of its SKIP slot
|
||||||
|
(let ((old-collector-length collector-length))
|
||||||
|
(unless (and (adjustable-array-p collector)
|
||||||
|
(array-has-fill-pointer-p collector))
|
||||||
|
(setq collector
|
||||||
|
(make-array collector-length
|
||||||
|
:initial-contents collector
|
||||||
|
:element-type 'character
|
||||||
|
:fill-pointer t
|
||||||
|
:adjustable t)
|
||||||
|
collector-start nil))
|
||||||
|
(adjust-array collector
|
||||||
|
(incf collector-length (len element))
|
||||||
|
:fill-pointer t)
|
||||||
|
(setf (subseq collector
|
||||||
|
old-collector-length)
|
||||||
|
(str element)
|
||||||
|
;; it suffices to remember the last SKIP slot
|
||||||
|
;; because due to the way MAYBE-ACCUMULATE
|
||||||
|
;; works adjacent STR objects have the same
|
||||||
|
;; SKIP value
|
||||||
|
skip (skip element)))
|
||||||
|
(setf (cdr curr-point) (cdr elements-rest)))
|
||||||
|
(t
|
||||||
|
(let ((collected-string
|
||||||
|
(cond (collector-start
|
||||||
|
collector-start)
|
||||||
|
(collector
|
||||||
|
;; if we have collected something already
|
||||||
|
;; we convert it into a STR
|
||||||
|
(make-instance 'str
|
||||||
|
:skip skip
|
||||||
|
:str collector
|
||||||
|
:case-insensitive-p
|
||||||
|
(eq old-case-mode
|
||||||
|
:case-insensitive)))
|
||||||
|
(t nil))))
|
||||||
|
(cond (case-mode
|
||||||
|
;; if ELEMENT is a string with a different case
|
||||||
|
;; mode than the last one we have either just
|
||||||
|
;; converted COLLECTOR into a STR or COLLECTOR
|
||||||
|
;; is still empty; in both cases we can now
|
||||||
|
;; begin to fill it anew
|
||||||
|
(setq collector (str element)
|
||||||
|
collector-start element
|
||||||
|
;; and we remember the SKIP value as above
|
||||||
|
skip (skip element)
|
||||||
|
collector-length (len element))
|
||||||
|
(cond (collected-string
|
||||||
|
(setf (car elements-rest)
|
||||||
|
collected-string
|
||||||
|
curr-point
|
||||||
|
(cdr curr-point)))
|
||||||
|
(t
|
||||||
|
(setf (cdr curr-point)
|
||||||
|
(cdr elements-rest)))))
|
||||||
|
(t
|
||||||
|
;; otherwise this is not a STR so we apply
|
||||||
|
;; GATHER-STRINGS to it and collect it directly
|
||||||
|
;; into RESULT
|
||||||
|
(cond (collected-string
|
||||||
|
(setf (car elements-rest)
|
||||||
|
collected-string
|
||||||
|
curr-point
|
||||||
|
(cdr curr-point)
|
||||||
|
(cdr curr-point)
|
||||||
|
(cons (gather-strings element)
|
||||||
|
(cdr curr-point))
|
||||||
|
curr-point
|
||||||
|
(cdr curr-point)))
|
||||||
|
(t
|
||||||
|
(setf (car elements-rest)
|
||||||
|
(gather-strings element)
|
||||||
|
curr-point
|
||||||
|
(cdr curr-point))))
|
||||||
|
;; we also have to empty COLLECTOR here in case
|
||||||
|
;; it was still filled from the last iteration
|
||||||
|
(setq collector nil
|
||||||
|
collector-start nil))))))
|
||||||
|
(setq old-case-mode case-mode))))
|
||||||
|
(when collector
|
||||||
|
(setf (cdr curr-point)
|
||||||
|
(cons
|
||||||
|
(make-instance 'str
|
||||||
|
:skip skip
|
||||||
|
:str collector
|
||||||
|
:case-insensitive-p
|
||||||
|
(eq old-case-mode
|
||||||
|
:case-insensitive))
|
||||||
|
nil)))
|
||||||
|
(setf (elements seq) (cdr start-point))
|
||||||
|
seq))
|
||||||
|
|
||||||
|
(defmethod gather-strings ((alternation alternation))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; loop ON the choices of ALTERNATION so we can modify them directly
|
||||||
|
(loop for choices-rest on (choices alternation)
|
||||||
|
while choices-rest
|
||||||
|
do (setf (car choices-rest)
|
||||||
|
(gather-strings (car choices-rest))))
|
||||||
|
alternation)
|
||||||
|
|
||||||
|
(defmethod gather-strings ((branch branch))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(with-slots (test then-regex else-regex)
|
||||||
|
branch
|
||||||
|
(setq test
|
||||||
|
(if (numberp test)
|
||||||
|
test
|
||||||
|
(gather-strings test))
|
||||||
|
then-regex (gather-strings then-regex)
|
||||||
|
else-regex (gather-strings else-regex))
|
||||||
|
branch))
|
||||||
|
|
||||||
|
(defmethod gather-strings ((regex regex))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(typecase regex
|
||||||
|
((or repetition register lookahead lookbehind standalone)
|
||||||
|
;; if REGEX contains exactly one inner REGEX object apply
|
||||||
|
;; GATHER-STRINGS to it
|
||||||
|
(setf (regex regex)
|
||||||
|
(gather-strings (regex regex)))
|
||||||
|
regex)
|
||||||
|
(t
|
||||||
|
;; otherwise (ANCHOR, BACK-REFERENCE, CHAR-CLASS, EVERYTHING,
|
||||||
|
;; LOOKAHEAD, LOOKBEHIND, STR, VOID, FILTER, and WORD-BOUNDARY)
|
||||||
|
;; do nothing
|
||||||
|
regex)))
|
||||||
|
|
||||||
|
;; Note that START-ANCHORED-P will be called after FLATTEN and GATHER-STRINGS.
|
||||||
|
|
||||||
|
(defgeneric start-anchored-p (regex &optional in-seq-p)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Returns T if REGEX starts with a \"real\" start
|
||||||
|
anchor, i.e. one that's not in multi-line mode, NIL otherwise. If
|
||||||
|
IN-SEQ-P is true the function will return :ZERO-LENGTH if REGEX is a
|
||||||
|
zero-length assertion."))
|
||||||
|
|
||||||
|
(defmethod start-anchored-p ((seq seq) &optional in-seq-p)
|
||||||
|
(declare (ignore in-seq-p))
|
||||||
|
;; note that START-ANCHORED-P is to be applied after FLATTEN and
|
||||||
|
;; GATHER-STRINGS, i.e. SEQ cannot be empty and cannot contain
|
||||||
|
;; embedded SEQ objects
|
||||||
|
(loop for element in (elements seq)
|
||||||
|
for anchored-p = (start-anchored-p element t)
|
||||||
|
;; skip zero-length elements because they won't affect the
|
||||||
|
;; "anchoredness" of the sequence
|
||||||
|
while (eq anchored-p :zero-length)
|
||||||
|
finally (return (and anchored-p (not (eq anchored-p :zero-length))))))
|
||||||
|
|
||||||
|
(defmethod start-anchored-p ((alternation alternation) &optional in-seq-p)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (ignore in-seq-p))
|
||||||
|
;; clearly an alternation can only be start-anchored if all of its
|
||||||
|
;; choices are start-anchored
|
||||||
|
(loop for choice in (choices alternation)
|
||||||
|
always (start-anchored-p choice)))
|
||||||
|
|
||||||
|
(defmethod start-anchored-p ((branch branch) &optional in-seq-p)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (ignore in-seq-p))
|
||||||
|
(and (start-anchored-p (then-regex branch))
|
||||||
|
(start-anchored-p (else-regex branch))))
|
||||||
|
|
||||||
|
(defmethod start-anchored-p ((repetition repetition) &optional in-seq-p)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (ignore in-seq-p))
|
||||||
|
;; well, this wouldn't make much sense, but anyway...
|
||||||
|
(and (plusp (minimum repetition))
|
||||||
|
(start-anchored-p (regex repetition))))
|
||||||
|
|
||||||
|
(defmethod start-anchored-p ((register register) &optional in-seq-p)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (ignore in-seq-p))
|
||||||
|
(start-anchored-p (regex register)))
|
||||||
|
|
||||||
|
(defmethod start-anchored-p ((standalone standalone) &optional in-seq-p)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (ignore in-seq-p))
|
||||||
|
(start-anchored-p (regex standalone)))
|
||||||
|
|
||||||
|
(defmethod start-anchored-p ((anchor anchor) &optional in-seq-p)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (ignore in-seq-p))
|
||||||
|
(and (startp anchor)
|
||||||
|
(not (multi-line-p anchor))))
|
||||||
|
|
||||||
|
(defmethod start-anchored-p ((regex regex) &optional in-seq-p)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(typecase regex
|
||||||
|
((or lookahead lookbehind word-boundary void)
|
||||||
|
;; zero-length assertions
|
||||||
|
(if in-seq-p
|
||||||
|
:zero-length
|
||||||
|
nil))
|
||||||
|
(filter
|
||||||
|
(if (and in-seq-p
|
||||||
|
(len regex)
|
||||||
|
(zerop (len regex)))
|
||||||
|
:zero-length
|
||||||
|
nil))
|
||||||
|
(t
|
||||||
|
;; BACK-REFERENCE, CHAR-CLASS, EVERYTHING, and STR
|
||||||
|
nil)))
|
||||||
|
|
||||||
|
;; Note that END-STRING-AUX will be called after FLATTEN and GATHER-STRINGS.
|
||||||
|
|
||||||
|
(defgeneric end-string-aux (regex &optional old-case-insensitive-p)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Returns the constant string (if it exists) REGEX
|
||||||
|
ends with wrapped into a STR object, otherwise NIL.
|
||||||
|
OLD-CASE-INSENSITIVE-P is the CASE-INSENSITIVE-P slot of the last STR
|
||||||
|
collected or :VOID if no STR has been collected yet. (This is a helper
|
||||||
|
function called by END-STRING.)"))
|
||||||
|
|
||||||
|
(defmethod end-string-aux ((str str)
|
||||||
|
&optional (old-case-insensitive-p :void))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special last-str))
|
||||||
|
(cond ((and (not (skip str)) ; avoid constituents of STARTS-WITH
|
||||||
|
;; only use STR if nothing has been collected yet or if
|
||||||
|
;; the collected string has the same value for
|
||||||
|
;; CASE-INSENSITIVE-P
|
||||||
|
(or (eq old-case-insensitive-p :void)
|
||||||
|
(eq (case-insensitive-p str) old-case-insensitive-p)))
|
||||||
|
(setf last-str str
|
||||||
|
;; set the SKIP property of this STR
|
||||||
|
(skip str) t)
|
||||||
|
str)
|
||||||
|
(t nil)))
|
||||||
|
|
||||||
|
(defmethod end-string-aux ((seq seq)
|
||||||
|
&optional (old-case-insensitive-p :void))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special continuep))
|
||||||
|
(let (case-insensitive-p
|
||||||
|
concatenated-string
|
||||||
|
concatenated-start
|
||||||
|
(concatenated-length 0))
|
||||||
|
(declare (fixnum concatenated-length))
|
||||||
|
(loop for element in (reverse (elements seq))
|
||||||
|
;; remember the case-(in)sensitivity of the last relevant
|
||||||
|
;; STR object
|
||||||
|
for loop-old-case-insensitive-p = old-case-insensitive-p
|
||||||
|
then (if skip
|
||||||
|
loop-old-case-insensitive-p
|
||||||
|
(case-insensitive-p element-end))
|
||||||
|
;; the end-string of the current element
|
||||||
|
for element-end = (end-string-aux element
|
||||||
|
loop-old-case-insensitive-p)
|
||||||
|
;; whether we encountered a zero-length element
|
||||||
|
for skip = (if element-end
|
||||||
|
(zerop (len element-end))
|
||||||
|
nil)
|
||||||
|
;; set CONTINUEP to NIL if we have to stop collecting to
|
||||||
|
;; alert END-STRING-AUX methods on enclosing SEQ objects
|
||||||
|
unless element-end
|
||||||
|
do (setq continuep nil)
|
||||||
|
;; end loop if we neither got a STR nor a zero-length
|
||||||
|
;; element
|
||||||
|
while element-end
|
||||||
|
;; only collect if not zero-length
|
||||||
|
unless skip
|
||||||
|
do (cond (concatenated-string
|
||||||
|
(when concatenated-start
|
||||||
|
(setf concatenated-string
|
||||||
|
(make-array concatenated-length
|
||||||
|
:initial-contents (reverse (str concatenated-start))
|
||||||
|
:element-type 'character
|
||||||
|
:fill-pointer t
|
||||||
|
:adjustable t)
|
||||||
|
concatenated-start nil))
|
||||||
|
(let ((len (len element-end))
|
||||||
|
(str (str element-end)))
|
||||||
|
(declare (fixnum len))
|
||||||
|
(incf concatenated-length len)
|
||||||
|
(loop for i of-type fixnum downfrom (1- len) to 0
|
||||||
|
do (vector-push-extend (char str i)
|
||||||
|
concatenated-string))))
|
||||||
|
(t
|
||||||
|
(setf concatenated-string
|
||||||
|
t
|
||||||
|
concatenated-start
|
||||||
|
element-end
|
||||||
|
concatenated-length
|
||||||
|
(len element-end)
|
||||||
|
case-insensitive-p
|
||||||
|
(case-insensitive-p element-end))))
|
||||||
|
;; stop collecting if END-STRING-AUX on inner SEQ has said so
|
||||||
|
while continuep)
|
||||||
|
(cond ((zerop concatenated-length)
|
||||||
|
;; don't bother to return zero-length strings
|
||||||
|
nil)
|
||||||
|
(concatenated-start
|
||||||
|
concatenated-start)
|
||||||
|
(t
|
||||||
|
(make-instance 'str
|
||||||
|
:str (nreverse concatenated-string)
|
||||||
|
:case-insensitive-p case-insensitive-p)))))
|
||||||
|
|
||||||
|
(defmethod end-string-aux ((register register)
|
||||||
|
&optional (old-case-insensitive-p :void))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(end-string-aux (regex register) old-case-insensitive-p))
|
||||||
|
|
||||||
|
(defmethod end-string-aux ((standalone standalone)
|
||||||
|
&optional (old-case-insensitive-p :void))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(end-string-aux (regex standalone) old-case-insensitive-p))
|
||||||
|
|
||||||
|
(defmethod end-string-aux ((regex regex)
|
||||||
|
&optional (old-case-insensitive-p :void))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special last-str end-anchored-p continuep))
|
||||||
|
(typecase regex
|
||||||
|
((or anchor lookahead lookbehind word-boundary void)
|
||||||
|
;; a zero-length REGEX object - for the sake of END-STRING-AUX
|
||||||
|
;; this is a zero-length string
|
||||||
|
(when (and (typep regex 'anchor)
|
||||||
|
(not (startp regex))
|
||||||
|
(or (no-newline-p regex)
|
||||||
|
(not (multi-line-p regex)))
|
||||||
|
(eq old-case-insensitive-p :void))
|
||||||
|
;; if this is a "real" end-anchor and we haven't collected
|
||||||
|
;; anything so far we can set END-ANCHORED-P (where 1 or 0
|
||||||
|
;; indicate whether we accept a #\Newline at the end or not)
|
||||||
|
(setq end-anchored-p (if (no-newline-p regex) 0 1)))
|
||||||
|
(make-instance 'str
|
||||||
|
:str ""
|
||||||
|
:case-insensitive-p :void))
|
||||||
|
(t
|
||||||
|
;; (ALTERNATION, BACK-REFERENCE, BRANCH, CHAR-CLASS, EVERYTHING,
|
||||||
|
;; REPETITION, FILTER)
|
||||||
|
nil)))
|
||||||
|
|
||||||
|
(defun end-string (regex)
|
||||||
|
(declare (special end-string-offset))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"Returns the constant string (if it exists) REGEX ends with wrapped
|
||||||
|
into a STR object, otherwise NIL."
|
||||||
|
;; LAST-STR points to the last STR object (seen from the end) that's
|
||||||
|
;; part of END-STRING; CONTINUEP is set to T if we stop collecting
|
||||||
|
;; in the middle of a SEQ
|
||||||
|
(let ((continuep t)
|
||||||
|
last-str)
|
||||||
|
(declare (special continuep last-str))
|
||||||
|
(prog1
|
||||||
|
(end-string-aux regex)
|
||||||
|
(when last-str
|
||||||
|
;; if we've found something set the START-OF-END-STRING-P of
|
||||||
|
;; the leftmost STR collected accordingly and remember the
|
||||||
|
;; OFFSET of this STR (in a special variable provided by the
|
||||||
|
;; caller of this function)
|
||||||
|
(setf (start-of-end-string-p last-str) t
|
||||||
|
end-string-offset (offset last-str))))))
|
||||||
|
|
||||||
|
(defgeneric compute-min-rest (regex current-min-rest)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Returns the minimal length of REGEX plus
|
||||||
|
CURRENT-MIN-REST. This is similar to REGEX-MIN-LENGTH except that it
|
||||||
|
recurses down into REGEX and sets the MIN-REST slots of REPETITION
|
||||||
|
objects."))
|
||||||
|
|
||||||
|
(defmethod compute-min-rest ((seq seq) current-min-rest)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(loop for element in (reverse (elements seq))
|
||||||
|
for last-min-rest = current-min-rest then this-min-rest
|
||||||
|
for this-min-rest = (compute-min-rest element last-min-rest)
|
||||||
|
finally (return this-min-rest)))
|
||||||
|
|
||||||
|
(defmethod compute-min-rest ((alternation alternation) current-min-rest)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(loop for choice in (choices alternation)
|
||||||
|
minimize (compute-min-rest choice current-min-rest)))
|
||||||
|
|
||||||
|
(defmethod compute-min-rest ((branch branch) current-min-rest)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(min (compute-min-rest (then-regex branch) current-min-rest)
|
||||||
|
(compute-min-rest (else-regex branch) current-min-rest)))
|
||||||
|
|
||||||
|
(defmethod compute-min-rest ((str str) current-min-rest)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(+ current-min-rest (len str)))
|
||||||
|
|
||||||
|
(defmethod compute-min-rest ((filter filter) current-min-rest)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(+ current-min-rest (or (len filter) 0)))
|
||||||
|
|
||||||
|
(defmethod compute-min-rest ((repetition repetition) current-min-rest)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(setf (min-rest repetition) current-min-rest)
|
||||||
|
(compute-min-rest (regex repetition) current-min-rest)
|
||||||
|
(+ current-min-rest (* (minimum repetition) (min-len repetition))))
|
||||||
|
|
||||||
|
(defmethod compute-min-rest ((register register) current-min-rest)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(compute-min-rest (regex register) current-min-rest))
|
||||||
|
|
||||||
|
(defmethod compute-min-rest ((standalone standalone) current-min-rest)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (ignore current-min-rest))
|
||||||
|
(compute-min-rest (regex standalone) 0))
|
||||||
|
|
||||||
|
(defmethod compute-min-rest ((lookahead lookahead) current-min-rest)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(compute-min-rest (regex lookahead) 0)
|
||||||
|
current-min-rest)
|
||||||
|
|
||||||
|
(defmethod compute-min-rest ((lookbehind lookbehind) current-min-rest)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(compute-min-rest (regex lookbehind) (+ current-min-rest (len lookbehind)))
|
||||||
|
current-min-rest)
|
||||||
|
|
||||||
|
(defmethod compute-min-rest ((regex regex) current-min-rest)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(typecase regex
|
||||||
|
((or char-class everything)
|
||||||
|
(1+ current-min-rest))
|
||||||
|
(t
|
||||||
|
;; zero min-len and no embedded regexes (ANCHOR,
|
||||||
|
;; BACK-REFERENCE, VOID, and WORD-BOUNDARY)
|
||||||
|
current-min-rest)))
|
||||||
|
|
@ -0,0 +1,69 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/packages.lisp,v 1.39 2009/09/17 19:17:31 edi Exp $
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre
|
||||||
|
(:nicknames :ppcre)
|
||||||
|
#+:genera
|
||||||
|
(:shadowing-import-from :common-lisp :lambda :simple-string :string)
|
||||||
|
(:use #-:genera :cl #+:genera :future-common-lisp)
|
||||||
|
(:shadow :digit-char-p :defconstant)
|
||||||
|
(:export :parse-string
|
||||||
|
:create-scanner
|
||||||
|
:create-optimized-test-function
|
||||||
|
:parse-tree-synonym
|
||||||
|
:define-parse-tree-synonym
|
||||||
|
:scan
|
||||||
|
:scan-to-strings
|
||||||
|
:do-scans
|
||||||
|
:do-matches
|
||||||
|
:do-matches-as-strings
|
||||||
|
:all-matches
|
||||||
|
:all-matches-as-strings
|
||||||
|
:split
|
||||||
|
:regex-replace
|
||||||
|
:regex-replace-all
|
||||||
|
:regex-apropos
|
||||||
|
:regex-apropos-list
|
||||||
|
:quote-meta-chars
|
||||||
|
:*regex-char-code-limit*
|
||||||
|
:*use-bmh-matchers*
|
||||||
|
:*allow-quoting*
|
||||||
|
:*allow-named-registers*
|
||||||
|
:*optimize-char-classes*
|
||||||
|
:*property-resolver*
|
||||||
|
:*look-ahead-for-suffix*
|
||||||
|
:ppcre-error
|
||||||
|
:ppcre-invocation-error
|
||||||
|
:ppcre-syntax-error
|
||||||
|
:ppcre-syntax-error-string
|
||||||
|
:ppcre-syntax-error-pos
|
||||||
|
:register-groups-bind
|
||||||
|
:do-register-groups))
|
||||||
|
|
@ -0,0 +1,290 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/parser.lisp,v 1.31 2009/09/17 19:17:31 edi Exp $
|
||||||
|
|
||||||
|
;;; The parser will - with the help of the lexer - parse a regex
|
||||||
|
;;; string and convert it into a "parse tree" (see docs for details
|
||||||
|
;;; about the syntax of these trees). Note that the lexer might
|
||||||
|
;;; return illegal parse trees. It is assumed that the conversion
|
||||||
|
;;; process later on will track them down.
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre)
|
||||||
|
|
||||||
|
(defun group (lexer)
|
||||||
|
"Parses and consumes a <group>.
|
||||||
|
The productions are: <group> -> \"\(\"<regex>\")\"
|
||||||
|
\"\(?:\"<regex>\")\"
|
||||||
|
\"\(?>\"<regex>\")\"
|
||||||
|
\"\(?<flags>:\"<regex>\")\"
|
||||||
|
\"\(?=\"<regex>\")\"
|
||||||
|
\"\(?!\"<regex>\")\"
|
||||||
|
\"\(?<=\"<regex>\")\"
|
||||||
|
\"\(?<!\"<regex>\")\"
|
||||||
|
\"\(?\(\"<num>\")\"<regex>\")\"
|
||||||
|
\"\(?\(\"<regex>\")\"<regex>\")\"
|
||||||
|
\"\(?<name>\"<regex>\")\" \(when *ALLOW-NAMED-REGISTERS* is T)
|
||||||
|
<legal-token>
|
||||||
|
where <flags> is parsed by the lexer function MAYBE-PARSE-FLAGS.
|
||||||
|
Will return <parse-tree> or \(<grouping-type> <parse-tree>) where
|
||||||
|
<grouping-type> is one of six keywords - see source for details."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(multiple-value-bind (open-token flags)
|
||||||
|
(get-token lexer)
|
||||||
|
(cond ((eq open-token :open-paren-paren)
|
||||||
|
;; special case for conditional regular expressions; note
|
||||||
|
;; that at this point we accept a couple of illegal
|
||||||
|
;; combinations which'll be sorted out later by the
|
||||||
|
;; converter
|
||||||
|
(let* ((open-paren-pos (car (lexer-last-pos lexer)))
|
||||||
|
;; check if what follows "(?(" is a number
|
||||||
|
(number (try-number lexer :no-whitespace-p t))
|
||||||
|
;; make changes to extended-mode-p local
|
||||||
|
(*extended-mode-p* *extended-mode-p*))
|
||||||
|
(declare (fixnum open-paren-pos))
|
||||||
|
(cond (number
|
||||||
|
;; condition is a number (i.e. refers to a
|
||||||
|
;; back-reference)
|
||||||
|
(let* ((inner-close-token (get-token lexer))
|
||||||
|
(reg-expr (reg-expr lexer))
|
||||||
|
(close-token (get-token lexer)))
|
||||||
|
(unless (eq inner-close-token :close-paren)
|
||||||
|
(signal-syntax-error* (+ open-paren-pos 2)
|
||||||
|
"Opening paren has no matching closing paren."))
|
||||||
|
(unless (eq close-token :close-paren)
|
||||||
|
(signal-syntax-error* open-paren-pos
|
||||||
|
"Opening paren has no matching closing paren."))
|
||||||
|
(list :branch number reg-expr)))
|
||||||
|
(t
|
||||||
|
;; condition must be a full regex (actually a
|
||||||
|
;; look-behind or look-ahead); and here comes a
|
||||||
|
;; terrible kludge: instead of being cleanly
|
||||||
|
;; separated from the lexer, the parser pushes
|
||||||
|
;; back the lexer by one position, thereby
|
||||||
|
;; landing in the middle of the 'token' "(?(" -
|
||||||
|
;; yuck!!
|
||||||
|
(decf (lexer-pos lexer))
|
||||||
|
(let* ((inner-reg-expr (group lexer))
|
||||||
|
(reg-expr (reg-expr lexer))
|
||||||
|
(close-token (get-token lexer)))
|
||||||
|
(unless (eq close-token :close-paren)
|
||||||
|
(signal-syntax-error* open-paren-pos
|
||||||
|
"Opening paren has no matching closing paren."))
|
||||||
|
(list :branch inner-reg-expr reg-expr))))))
|
||||||
|
((member open-token '(:open-paren
|
||||||
|
:open-paren-colon
|
||||||
|
:open-paren-greater
|
||||||
|
:open-paren-equal
|
||||||
|
:open-paren-exclamation
|
||||||
|
:open-paren-less-equal
|
||||||
|
:open-paren-less-exclamation
|
||||||
|
:open-paren-less-letter)
|
||||||
|
:test #'eq)
|
||||||
|
;; make changes to extended-mode-p local
|
||||||
|
(let ((*extended-mode-p* *extended-mode-p*))
|
||||||
|
;; we saw one of the six token representing opening
|
||||||
|
;; parentheses
|
||||||
|
(let* ((open-paren-pos (car (lexer-last-pos lexer)))
|
||||||
|
(register-name (when (eq open-token :open-paren-less-letter)
|
||||||
|
(parse-register-name-aux lexer)))
|
||||||
|
(reg-expr (reg-expr lexer))
|
||||||
|
(close-token (get-token lexer)))
|
||||||
|
(when (or (eq open-token :open-paren)
|
||||||
|
(eq open-token :open-paren-less-letter))
|
||||||
|
;; if this is the "("<regex>")" or "(?"<name>""<regex>")" production we have to
|
||||||
|
;; increment the register counter of the lexer
|
||||||
|
(incf (lexer-reg lexer)))
|
||||||
|
(unless (eq close-token :close-paren)
|
||||||
|
;; the token following <regex> must be the closing
|
||||||
|
;; parenthesis or this is a syntax error
|
||||||
|
(signal-syntax-error* open-paren-pos
|
||||||
|
"Opening paren has no matching closing paren."))
|
||||||
|
(if flags
|
||||||
|
;; if the lexer has returned a list of flags this must
|
||||||
|
;; have been the "(?:"<regex>")" production
|
||||||
|
(cons :group (nconc flags (list reg-expr)))
|
||||||
|
(if (eq open-token :open-paren-less-letter)
|
||||||
|
(list :named-register register-name
|
||||||
|
reg-expr)
|
||||||
|
(list (case open-token
|
||||||
|
((:open-paren)
|
||||||
|
:register)
|
||||||
|
((:open-paren-colon)
|
||||||
|
:group)
|
||||||
|
((:open-paren-greater)
|
||||||
|
:standalone)
|
||||||
|
((:open-paren-equal)
|
||||||
|
:positive-lookahead)
|
||||||
|
((:open-paren-exclamation)
|
||||||
|
:negative-lookahead)
|
||||||
|
((:open-paren-less-equal)
|
||||||
|
:positive-lookbehind)
|
||||||
|
((:open-paren-less-exclamation)
|
||||||
|
:negative-lookbehind))
|
||||||
|
reg-expr))))))
|
||||||
|
(t
|
||||||
|
;; this is the <legal-token> production; <legal-token> is
|
||||||
|
;; any token which passes START-OF-SUBEXPR-P (otherwise
|
||||||
|
;; parsing had already stopped in the SEQ method)
|
||||||
|
open-token))))
|
||||||
|
|
||||||
|
(defun greedy-quant (lexer)
|
||||||
|
"Parses and consumes a <greedy-quant>.
|
||||||
|
The productions are: <greedy-quant> -> <group> | <group><quantifier>
|
||||||
|
where <quantifier> is parsed by the lexer function GET-QUANTIFIER.
|
||||||
|
Will return <parse-tree> or (:GREEDY-REPETITION <min> <max> <parse-tree>)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let* ((group (group lexer))
|
||||||
|
(token (get-quantifier lexer)))
|
||||||
|
(if token
|
||||||
|
;; if GET-QUANTIFIER returned a non-NIL value it's the
|
||||||
|
;; two-element list (<min> <max>)
|
||||||
|
(list :greedy-repetition (first token) (second token) group)
|
||||||
|
group)))
|
||||||
|
|
||||||
|
(defun quant (lexer)
|
||||||
|
"Parses and consumes a <quant>.
|
||||||
|
The productions are: <quant> -> <greedy-quant> | <greedy-quant>\"?\".
|
||||||
|
Will return the <parse-tree> returned by GREEDY-QUANT and optionally
|
||||||
|
change :GREEDY-REPETITION to :NON-GREEDY-REPETITION."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let* ((greedy-quant (greedy-quant lexer))
|
||||||
|
(pos (lexer-pos lexer))
|
||||||
|
(next-char (next-char lexer)))
|
||||||
|
(when next-char
|
||||||
|
(if (char= next-char #\?)
|
||||||
|
(setf (car greedy-quant) :non-greedy-repetition)
|
||||||
|
(setf (lexer-pos lexer) pos)))
|
||||||
|
greedy-quant))
|
||||||
|
|
||||||
|
(defun seq (lexer)
|
||||||
|
"Parses and consumes a <seq>.
|
||||||
|
The productions are: <seq> -> <quant> | <quant><seq>.
|
||||||
|
Will return <parse-tree> or (:SEQUENCE <parse-tree> <parse-tree>)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(flet ((make-array-from-two-chars (char1 char2)
|
||||||
|
(let ((string (make-array 2
|
||||||
|
:element-type 'character
|
||||||
|
:fill-pointer t
|
||||||
|
:adjustable t)))
|
||||||
|
(setf (aref string 0) char1)
|
||||||
|
(setf (aref string 1) char2)
|
||||||
|
string)))
|
||||||
|
;; Note that we're calling START-OF-SUBEXPR-P before we actually try
|
||||||
|
;; to parse a <seq> or <quant> in order to catch empty regular
|
||||||
|
;; expressions
|
||||||
|
(if (start-of-subexpr-p lexer)
|
||||||
|
(loop with seq-is-sequence-p = nil
|
||||||
|
with last-cdr
|
||||||
|
for quant = (quant lexer)
|
||||||
|
for quant-is-char-p = (characterp quant)
|
||||||
|
for seq = quant
|
||||||
|
then
|
||||||
|
(cond ((and quant-is-char-p (characterp seq))
|
||||||
|
(make-array-from-two-chars seq quant))
|
||||||
|
((and quant-is-char-p (stringp seq))
|
||||||
|
(vector-push-extend quant seq)
|
||||||
|
seq)
|
||||||
|
((not seq-is-sequence-p)
|
||||||
|
(setf last-cdr (list quant)
|
||||||
|
seq-is-sequence-p t)
|
||||||
|
(list* :sequence seq last-cdr))
|
||||||
|
((and quant-is-char-p
|
||||||
|
(characterp (car last-cdr)))
|
||||||
|
(setf (car last-cdr)
|
||||||
|
(make-array-from-two-chars (car last-cdr)
|
||||||
|
quant))
|
||||||
|
seq)
|
||||||
|
((and quant-is-char-p
|
||||||
|
(stringp (car last-cdr)))
|
||||||
|
(vector-push-extend quant (car last-cdr))
|
||||||
|
seq)
|
||||||
|
(t
|
||||||
|
;; if <seq> is also a :SEQUENCE parse tree we merge
|
||||||
|
;; both lists into one
|
||||||
|
(let ((cons (list quant)))
|
||||||
|
(psetf last-cdr cons
|
||||||
|
(cdr last-cdr) cons))
|
||||||
|
seq))
|
||||||
|
while (start-of-subexpr-p lexer)
|
||||||
|
finally (return seq))
|
||||||
|
:void)))
|
||||||
|
|
||||||
|
(defun reg-expr (lexer)
|
||||||
|
"Parses and consumes a <regex>, a complete regular expression.
|
||||||
|
The productions are: <regex> -> <seq> | <seq>\"|\"<regex>.
|
||||||
|
Will return <parse-tree> or (:ALTERNATION <parse-tree> <parse-tree>)."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let ((pos (lexer-pos lexer)))
|
||||||
|
(case (next-char lexer)
|
||||||
|
((nil)
|
||||||
|
;; if we didn't get any token we return :VOID which stands for
|
||||||
|
;; "empty regular expression"
|
||||||
|
:void)
|
||||||
|
((#\|)
|
||||||
|
;; now check whether the expression started with a vertical
|
||||||
|
;; bar, i.e. <seq> - the left alternation - is empty
|
||||||
|
(list :alternation :void (reg-expr lexer)))
|
||||||
|
(otherwise
|
||||||
|
;; otherwise un-read the character we just saw and parse a
|
||||||
|
;; <seq> plus the character following it
|
||||||
|
(setf (lexer-pos lexer) pos)
|
||||||
|
(let* ((seq (seq lexer))
|
||||||
|
(pos (lexer-pos lexer)))
|
||||||
|
(case (next-char lexer)
|
||||||
|
((nil)
|
||||||
|
;; no further character, just a <seq>
|
||||||
|
seq)
|
||||||
|
((#\|)
|
||||||
|
;; if the character was a vertical bar, this is an
|
||||||
|
;; alternation and we have the second production
|
||||||
|
(let ((reg-expr (reg-expr lexer)))
|
||||||
|
(cond ((and (consp reg-expr)
|
||||||
|
(eq (first reg-expr) :alternation))
|
||||||
|
;; again we try to merge as above in SEQ
|
||||||
|
(setf (cdr reg-expr)
|
||||||
|
(cons seq (cdr reg-expr)))
|
||||||
|
reg-expr)
|
||||||
|
(t (list :alternation seq reg-expr)))))
|
||||||
|
(otherwise
|
||||||
|
;; a character which is not a vertical bar - this is
|
||||||
|
;; either a syntax error or we're inside of a group and
|
||||||
|
;; the next character is a closing parenthesis; so we
|
||||||
|
;; just un-read the character and let another function
|
||||||
|
;; take care of it
|
||||||
|
(setf (lexer-pos lexer) pos)
|
||||||
|
seq)))))))
|
||||||
|
|
||||||
|
(defun parse-string (string)
|
||||||
|
"Translate the regex string STRING into a parse tree."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let* ((lexer (make-lexer string))
|
||||||
|
(parse-tree (reg-expr lexer)))
|
||||||
|
;; check whether we've consumed the whole regex string
|
||||||
|
(if (end-of-string-p lexer)
|
||||||
|
parse-tree
|
||||||
|
(signal-syntax-error* (lexer-pos lexer) "Expected end of string."))))
|
||||||
|
|
@ -0,0 +1,555 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/regex-class-util.lisp,v 1.9 2009/09/17 19:17:31 edi Exp $
|
||||||
|
|
||||||
|
;;; This file contains some utility methods for REGEX objects.
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre)
|
||||||
|
|
||||||
|
;;; The following four methods allow a VOID object to behave like a
|
||||||
|
;;; zero-length STR object (only readers needed)
|
||||||
|
|
||||||
|
(defmethod len ((void void))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
0)
|
||||||
|
|
||||||
|
(defmethod str ((void void))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
"")
|
||||||
|
|
||||||
|
(defmethod skip ((void void))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(defmethod start-of-end-string-p ((void void))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(defgeneric case-mode (regex old-case-mode)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Utility function used by the optimizer (see GATHER-STRINGS).
|
||||||
|
Returns a keyword denoting the case-(in)sensitivity of a STR or its
|
||||||
|
second argument if the STR has length 0. Returns NIL for REGEX objects
|
||||||
|
which are not of type STR."))
|
||||||
|
|
||||||
|
(defmethod case-mode ((str str) old-case-mode)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(cond ((zerop (len str))
|
||||||
|
old-case-mode)
|
||||||
|
((case-insensitive-p str)
|
||||||
|
:case-insensitive)
|
||||||
|
(t
|
||||||
|
:case-sensitive)))
|
||||||
|
|
||||||
|
(defmethod case-mode ((regex regex) old-case-mode)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (ignore old-case-mode))
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(defgeneric copy-regex (regex)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Implements a deep copy of a REGEX object."))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((anchor anchor))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'anchor
|
||||||
|
:startp (startp anchor)
|
||||||
|
:multi-line-p (multi-line-p anchor)
|
||||||
|
:no-newline-p (no-newline-p anchor)))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((everything everything))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'everything
|
||||||
|
:single-line-p (single-line-p everything)))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((word-boundary word-boundary))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'word-boundary
|
||||||
|
:negatedp (negatedp word-boundary)))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((void void))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'void))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((lookahead lookahead))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'lookahead
|
||||||
|
:regex (copy-regex (regex lookahead))
|
||||||
|
:positivep (positivep lookahead)))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((seq seq))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'seq
|
||||||
|
:elements (mapcar #'copy-regex (elements seq))))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((alternation alternation))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'alternation
|
||||||
|
:choices (mapcar #'copy-regex (choices alternation))))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((branch branch))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(with-slots (test)
|
||||||
|
branch
|
||||||
|
(make-instance 'branch
|
||||||
|
:test (if (typep test 'regex)
|
||||||
|
(copy-regex test)
|
||||||
|
test)
|
||||||
|
:then-regex (copy-regex (then-regex branch))
|
||||||
|
:else-regex (copy-regex (else-regex branch)))))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((lookbehind lookbehind))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'lookbehind
|
||||||
|
:regex (copy-regex (regex lookbehind))
|
||||||
|
:positivep (positivep lookbehind)
|
||||||
|
:len (len lookbehind)))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((repetition repetition))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'repetition
|
||||||
|
:regex (copy-regex (regex repetition))
|
||||||
|
:greedyp (greedyp repetition)
|
||||||
|
:minimum (minimum repetition)
|
||||||
|
:maximum (maximum repetition)
|
||||||
|
:min-len (min-len repetition)
|
||||||
|
:len (len repetition)
|
||||||
|
:contains-register-p (contains-register-p repetition)))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((register register))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'register
|
||||||
|
:regex (copy-regex (regex register))
|
||||||
|
:num (num register)
|
||||||
|
:name (name register)))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((standalone standalone))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'standalone
|
||||||
|
:regex (copy-regex (regex standalone))))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((back-reference back-reference))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'back-reference
|
||||||
|
:num (num back-reference)
|
||||||
|
:case-insensitive-p (case-insensitive-p back-reference)))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((char-class char-class))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'char-class
|
||||||
|
:test-function (test-function char-class)))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((str str))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'str
|
||||||
|
:str (str str)
|
||||||
|
:case-insensitive-p (case-insensitive-p str)))
|
||||||
|
|
||||||
|
(defmethod copy-regex ((filter filter))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'filter
|
||||||
|
:fn (fn filter)
|
||||||
|
:len (len filter)))
|
||||||
|
|
||||||
|
;;; Note that COPY-REGEX and REMOVE-REGISTERS could have easily been
|
||||||
|
;;; wrapped into one function. Maybe in the next release...
|
||||||
|
|
||||||
|
;;; Further note that this function is used by CONVERT to factor out
|
||||||
|
;;; complicated repetitions, i.e. cases like
|
||||||
|
;;; (a)* -> (?:a*(a))?
|
||||||
|
;;; This won't work for, say,
|
||||||
|
;;; ((a)|(b))* -> (?:(?:a|b)*((a)|(b)))?
|
||||||
|
;;; and therefore we stop REGISTER removal once we see an ALTERNATION.
|
||||||
|
|
||||||
|
(defgeneric remove-registers (regex)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Returns a deep copy of a REGEX (see COPY-REGEX) and
|
||||||
|
optionally removes embedded REGISTER objects if possible and if the
|
||||||
|
special variable REMOVE-REGISTERS-P is true."))
|
||||||
|
|
||||||
|
(defmethod remove-registers ((register register))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special remove-registers-p reg-seen))
|
||||||
|
(cond (remove-registers-p
|
||||||
|
(remove-registers (regex register)))
|
||||||
|
(t
|
||||||
|
;; mark REG-SEEN as true so enclosing REPETITION objects
|
||||||
|
;; (see method below) know if they contain a register or not
|
||||||
|
(setq reg-seen t)
|
||||||
|
(copy-regex register))))
|
||||||
|
|
||||||
|
(defmethod remove-registers ((repetition repetition))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let* (reg-seen
|
||||||
|
(inner-regex (remove-registers (regex repetition))))
|
||||||
|
;; REMOVE-REGISTERS will set REG-SEEN (see method above) if
|
||||||
|
;; (REGEX REPETITION) contains a REGISTER
|
||||||
|
(declare (special reg-seen))
|
||||||
|
(make-instance 'repetition
|
||||||
|
:regex inner-regex
|
||||||
|
:greedyp (greedyp repetition)
|
||||||
|
:minimum (minimum repetition)
|
||||||
|
:maximum (maximum repetition)
|
||||||
|
:min-len (min-len repetition)
|
||||||
|
:len (len repetition)
|
||||||
|
:contains-register-p reg-seen)))
|
||||||
|
|
||||||
|
(defmethod remove-registers ((standalone standalone))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'standalone
|
||||||
|
:regex (remove-registers (regex standalone))))
|
||||||
|
|
||||||
|
(defmethod remove-registers ((lookahead lookahead))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'lookahead
|
||||||
|
:regex (remove-registers (regex lookahead))
|
||||||
|
:positivep (positivep lookahead)))
|
||||||
|
|
||||||
|
(defmethod remove-registers ((lookbehind lookbehind))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'lookbehind
|
||||||
|
:regex (remove-registers (regex lookbehind))
|
||||||
|
:positivep (positivep lookbehind)
|
||||||
|
:len (len lookbehind)))
|
||||||
|
|
||||||
|
(defmethod remove-registers ((branch branch))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(with-slots (test)
|
||||||
|
branch
|
||||||
|
(make-instance 'branch
|
||||||
|
:test (if (typep test 'regex)
|
||||||
|
(remove-registers test)
|
||||||
|
test)
|
||||||
|
:then-regex (remove-registers (then-regex branch))
|
||||||
|
:else-regex (remove-registers (else-regex branch)))))
|
||||||
|
|
||||||
|
(defmethod remove-registers ((alternation alternation))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (special remove-registers-p))
|
||||||
|
;; an ALTERNATION, so we can't remove REGISTER objects further down
|
||||||
|
(setq remove-registers-p nil)
|
||||||
|
(copy-regex alternation))
|
||||||
|
|
||||||
|
(defmethod remove-registers ((regex regex))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(copy-regex regex))
|
||||||
|
|
||||||
|
(defmethod remove-registers ((seq seq))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(make-instance 'seq
|
||||||
|
:elements (mapcar #'remove-registers (elements seq))))
|
||||||
|
|
||||||
|
(defgeneric everythingp (regex)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Returns an EVERYTHING object if REGEX is equivalent
|
||||||
|
to this object, otherwise NIL. So, \"(.){1}\" would return true
|
||||||
|
\(i.e. the object corresponding to \".\", for example."))
|
||||||
|
|
||||||
|
(defmethod everythingp ((seq seq))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; we might have degenerate cases like (:SEQUENCE :VOID ...)
|
||||||
|
;; due to the parsing process
|
||||||
|
(let ((cleaned-elements (remove-if #'(lambda (element)
|
||||||
|
(typep element 'void))
|
||||||
|
(elements seq))))
|
||||||
|
(and (= 1 (length cleaned-elements))
|
||||||
|
(everythingp (first cleaned-elements)))))
|
||||||
|
|
||||||
|
(defmethod everythingp ((alternation alternation))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(with-slots (choices)
|
||||||
|
alternation
|
||||||
|
(and (= 1 (length choices))
|
||||||
|
;; this is unlikely to happen for human-generated regexes,
|
||||||
|
;; but machine-generated ones might look like this
|
||||||
|
(everythingp (first choices)))))
|
||||||
|
|
||||||
|
(defmethod everythingp ((repetition repetition))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(with-slots (maximum minimum regex)
|
||||||
|
repetition
|
||||||
|
(and maximum
|
||||||
|
(= 1 minimum maximum)
|
||||||
|
;; treat "<regex>{1,1}" like "<regex>"
|
||||||
|
(everythingp regex))))
|
||||||
|
|
||||||
|
(defmethod everythingp ((register register))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(everythingp (regex register)))
|
||||||
|
|
||||||
|
(defmethod everythingp ((standalone standalone))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(everythingp (regex standalone)))
|
||||||
|
|
||||||
|
(defmethod everythingp ((everything everything))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
everything)
|
||||||
|
|
||||||
|
(defmethod everythingp ((regex regex))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; the general case for ANCHOR, BACK-REFERENCE, BRANCH, CHAR-CLASS,
|
||||||
|
;; LOOKAHEAD, LOOKBEHIND, STR, VOID, FILTER, and WORD-BOUNDARY
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(defgeneric regex-length (regex)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Return the length of REGEX if it is fixed, NIL otherwise."))
|
||||||
|
|
||||||
|
(defmethod regex-length ((seq seq))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; simply add all inner lengths unless one of them is NIL
|
||||||
|
(loop for sub-regex in (elements seq)
|
||||||
|
for len = (regex-length sub-regex)
|
||||||
|
if (not len) do (return nil)
|
||||||
|
sum len))
|
||||||
|
|
||||||
|
(defmethod regex-length ((alternation alternation))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; only return a true value if all inner lengths are non-NIL and
|
||||||
|
;; mutually equal
|
||||||
|
(loop for sub-regex in (choices alternation)
|
||||||
|
for old-len = nil then len
|
||||||
|
for len = (regex-length sub-regex)
|
||||||
|
if (or (not len)
|
||||||
|
(and old-len (/= len old-len))) do (return nil)
|
||||||
|
finally (return len)))
|
||||||
|
|
||||||
|
(defmethod regex-length ((branch branch))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; only return a true value if both alternations have a length and
|
||||||
|
;; if they're equal
|
||||||
|
(let ((then-length (regex-length (then-regex branch))))
|
||||||
|
(and then-length
|
||||||
|
(eql then-length (regex-length (else-regex branch)))
|
||||||
|
then-length)))
|
||||||
|
|
||||||
|
(defmethod regex-length ((repetition repetition))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; we can only compute the length of a REPETITION object if the
|
||||||
|
;; number of repetitions is fixed; note that we don't call
|
||||||
|
;; REGEX-LENGTH for the inner regex, we assume that the LEN slot is
|
||||||
|
;; always set correctly
|
||||||
|
(with-slots (len minimum maximum)
|
||||||
|
repetition
|
||||||
|
(if (and len
|
||||||
|
(eql minimum maximum))
|
||||||
|
(* minimum len)
|
||||||
|
nil)))
|
||||||
|
|
||||||
|
(defmethod regex-length ((register register))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(regex-length (regex register)))
|
||||||
|
|
||||||
|
(defmethod regex-length ((standalone standalone))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(regex-length (regex standalone)))
|
||||||
|
|
||||||
|
(defmethod regex-length ((back-reference back-reference))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; with enough effort we could possibly do better here, but
|
||||||
|
;; currently we just give up and return NIL
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(defmethod regex-length ((char-class char-class))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
1)
|
||||||
|
|
||||||
|
(defmethod regex-length ((everything everything))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
1)
|
||||||
|
|
||||||
|
(defmethod regex-length ((str str))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(len str))
|
||||||
|
|
||||||
|
(defmethod regex-length ((filter filter))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(len filter))
|
||||||
|
|
||||||
|
(defmethod regex-length ((regex regex))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; the general case for ANCHOR, LOOKAHEAD, LOOKBEHIND, VOID, and
|
||||||
|
;; WORD-BOUNDARY (which all have zero-length)
|
||||||
|
0)
|
||||||
|
|
||||||
|
(defgeneric regex-min-length (regex)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Returns the minimal length of REGEX."))
|
||||||
|
|
||||||
|
(defmethod regex-min-length ((seq seq))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; simply add all inner minimal lengths
|
||||||
|
(loop for sub-regex in (elements seq)
|
||||||
|
for len = (regex-min-length sub-regex)
|
||||||
|
sum len))
|
||||||
|
|
||||||
|
(defmethod regex-min-length ((alternation alternation))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; minimal length of an alternation is the minimal length of the
|
||||||
|
;; "shortest" element
|
||||||
|
(loop for sub-regex in (choices alternation)
|
||||||
|
for len = (regex-min-length sub-regex)
|
||||||
|
minimize len))
|
||||||
|
|
||||||
|
(defmethod regex-min-length ((branch branch))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; minimal length of both alternations
|
||||||
|
(min (regex-min-length (then-regex branch))
|
||||||
|
(regex-min-length (else-regex branch))))
|
||||||
|
|
||||||
|
(defmethod regex-min-length ((repetition repetition))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; obviously the product of the inner minimal length and the minimal
|
||||||
|
;; number of repetitions
|
||||||
|
(* (minimum repetition) (min-len repetition)))
|
||||||
|
|
||||||
|
(defmethod regex-min-length ((register register))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(regex-min-length (regex register)))
|
||||||
|
|
||||||
|
(defmethod regex-min-length ((standalone standalone))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(regex-min-length (regex standalone)))
|
||||||
|
|
||||||
|
(defmethod regex-min-length ((char-class char-class))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
1)
|
||||||
|
|
||||||
|
(defmethod regex-min-length ((everything everything))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
1)
|
||||||
|
|
||||||
|
(defmethod regex-min-length ((str str))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(len str))
|
||||||
|
|
||||||
|
(defmethod regex-min-length ((filter filter))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(or (len filter)
|
||||||
|
0))
|
||||||
|
|
||||||
|
(defmethod regex-min-length ((regex regex))
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; the general case for ANCHOR, BACK-REFERENCE, LOOKAHEAD,
|
||||||
|
;; LOOKBEHIND, VOID, and WORD-BOUNDARY
|
||||||
|
0)
|
||||||
|
|
||||||
|
(defgeneric compute-offsets (regex start-pos)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Returns the offset the following regex would have
|
||||||
|
relative to START-POS or NIL if we can't compute it. Sets the OFFSET
|
||||||
|
slot of REGEX to START-POS if REGEX is a STR. May also affect OFFSET
|
||||||
|
slots of STR objects further down the tree."))
|
||||||
|
|
||||||
|
;; note that we're actually only interested in the offset of
|
||||||
|
;; "top-level" STR objects (see ADVANCE-FN in the SCAN function) so we
|
||||||
|
;; can stop at variable-length alternations and don't need to descend
|
||||||
|
;; into repetitions
|
||||||
|
|
||||||
|
(defmethod compute-offsets ((seq seq) start-pos)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(loop for element in (elements seq)
|
||||||
|
;; advance offset argument for next call while looping through
|
||||||
|
;; the elements
|
||||||
|
for pos = start-pos then curr-offset
|
||||||
|
for curr-offset = (compute-offsets element pos)
|
||||||
|
while curr-offset
|
||||||
|
finally (return curr-offset)))
|
||||||
|
|
||||||
|
(defmethod compute-offsets ((alternation alternation) start-pos)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(loop for choice in (choices alternation)
|
||||||
|
for old-offset = nil then curr-offset
|
||||||
|
for curr-offset = (compute-offsets choice start-pos)
|
||||||
|
;; we stop immediately if two alternations don't result in the
|
||||||
|
;; same offset
|
||||||
|
if (or (not curr-offset)
|
||||||
|
(and old-offset (/= curr-offset old-offset)))
|
||||||
|
do (return nil)
|
||||||
|
finally (return curr-offset)))
|
||||||
|
|
||||||
|
(defmethod compute-offsets ((branch branch) start-pos)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; only return offset if both alternations have equal value
|
||||||
|
(let ((then-offset (compute-offsets (then-regex branch) start-pos)))
|
||||||
|
(and then-offset
|
||||||
|
(eql then-offset (compute-offsets (else-regex branch) start-pos))
|
||||||
|
then-offset)))
|
||||||
|
|
||||||
|
(defmethod compute-offsets ((repetition repetition) start-pos)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; no need to descend into the inner regex
|
||||||
|
(with-slots (len minimum maximum)
|
||||||
|
repetition
|
||||||
|
(if (and len
|
||||||
|
(eq minimum maximum))
|
||||||
|
;; fixed number of repetitions, so we know how to proceed
|
||||||
|
(+ start-pos (* minimum len))
|
||||||
|
;; otherwise return NIL
|
||||||
|
nil)))
|
||||||
|
|
||||||
|
(defmethod compute-offsets ((register register) start-pos)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(compute-offsets (regex register) start-pos))
|
||||||
|
|
||||||
|
(defmethod compute-offsets ((standalone standalone) start-pos)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(compute-offsets (regex standalone) start-pos))
|
||||||
|
|
||||||
|
(defmethod compute-offsets ((char-class char-class) start-pos)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(1+ start-pos))
|
||||||
|
|
||||||
|
(defmethod compute-offsets ((everything everything) start-pos)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(1+ start-pos))
|
||||||
|
|
||||||
|
(defmethod compute-offsets ((str str) start-pos)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(setf (offset str) start-pos)
|
||||||
|
(+ start-pos (len str)))
|
||||||
|
|
||||||
|
(defmethod compute-offsets ((back-reference back-reference) start-pos)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; with enough effort we could possibly do better here, but
|
||||||
|
;; currently we just give up and return NIL
|
||||||
|
(declare (ignore start-pos))
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(defmethod compute-offsets ((filter filter) start-pos)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let ((len (len filter)))
|
||||||
|
(if len
|
||||||
|
(+ start-pos len)
|
||||||
|
nil)))
|
||||||
|
|
||||||
|
(defmethod compute-offsets ((regex regex) start-pos)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; the general case for ANCHOR, LOOKAHEAD, LOOKBEHIND, VOID, and
|
||||||
|
;; WORD-BOUNDARY (which all have zero-length)
|
||||||
|
start-pos)
|
||||||
|
|
@ -0,0 +1,271 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/regex-class.lisp,v 1.44 2009/10/28 07:36:15 edi Exp $
|
||||||
|
|
||||||
|
;;; This file defines the REGEX class. REGEX objects are used to
|
||||||
|
;;; represent the (transformed) parse trees internally
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre)
|
||||||
|
|
||||||
|
(defclass regex ()
|
||||||
|
()
|
||||||
|
(:documentation "The REGEX base class. All other classes inherit
|
||||||
|
from this one."))
|
||||||
|
|
||||||
|
(defclass seq (regex)
|
||||||
|
((elements :initarg :elements
|
||||||
|
:accessor elements
|
||||||
|
:type cons
|
||||||
|
:documentation "A list of REGEX objects."))
|
||||||
|
(:documentation "SEQ objects represents sequences of regexes.
|
||||||
|
\(Like \"ab\" is the sequence of \"a\" and \"b\".)"))
|
||||||
|
|
||||||
|
(defclass alternation (regex)
|
||||||
|
((choices :initarg :choices
|
||||||
|
:accessor choices
|
||||||
|
:type cons
|
||||||
|
:documentation "A list of REGEX objects"))
|
||||||
|
(:documentation "ALTERNATION objects represent alternations of
|
||||||
|
regexes. \(Like \"a|b\" ist the alternation of \"a\" or \"b\".)"))
|
||||||
|
|
||||||
|
(defclass lookahead (regex)
|
||||||
|
((regex :initarg :regex
|
||||||
|
:accessor regex
|
||||||
|
:documentation "The REGEX object we're checking.")
|
||||||
|
(positivep :initarg :positivep
|
||||||
|
:reader positivep
|
||||||
|
:documentation "Whether this assertion is positive."))
|
||||||
|
(:documentation "LOOKAHEAD objects represent look-ahead assertions."))
|
||||||
|
|
||||||
|
(defclass lookbehind (regex)
|
||||||
|
((regex :initarg :regex
|
||||||
|
:accessor regex
|
||||||
|
:documentation "The REGEX object we're checking.")
|
||||||
|
(positivep :initarg :positivep
|
||||||
|
:reader positivep
|
||||||
|
:documentation "Whether this assertion is positive.")
|
||||||
|
(len :initarg :len
|
||||||
|
:accessor len
|
||||||
|
:type fixnum
|
||||||
|
:documentation "The \(fixed) length of the enclosed regex."))
|
||||||
|
(:documentation "LOOKBEHIND objects represent look-behind assertions."))
|
||||||
|
|
||||||
|
(defclass repetition (regex)
|
||||||
|
((regex :initarg :regex
|
||||||
|
:accessor regex
|
||||||
|
:documentation "The REGEX that's repeated.")
|
||||||
|
(greedyp :initarg :greedyp
|
||||||
|
:reader greedyp
|
||||||
|
:documentation "Whether the repetition is greedy.")
|
||||||
|
(minimum :initarg :minimum
|
||||||
|
:accessor minimum
|
||||||
|
:type fixnum
|
||||||
|
:documentation "The minimal number of repetitions.")
|
||||||
|
(maximum :initarg :maximum
|
||||||
|
:accessor maximum
|
||||||
|
:documentation "The maximal number of repetitions.
|
||||||
|
Can be NIL for unbounded.")
|
||||||
|
(min-len :initarg :min-len
|
||||||
|
:reader min-len
|
||||||
|
:documentation "The minimal length of the enclosed regex.")
|
||||||
|
(len :initarg :len
|
||||||
|
:reader len
|
||||||
|
:documentation "The length of the enclosed regex. NIL if
|
||||||
|
unknown.")
|
||||||
|
(min-rest :initform 0
|
||||||
|
:accessor min-rest
|
||||||
|
:type fixnum
|
||||||
|
:documentation "The minimal number of characters which
|
||||||
|
must appear after this repetition.")
|
||||||
|
(contains-register-p :initarg :contains-register-p
|
||||||
|
:reader contains-register-p
|
||||||
|
:documentation "Whether the regex contains a
|
||||||
|
register."))
|
||||||
|
(:documentation "REPETITION objects represent repetitions of regexes."))
|
||||||
|
|
||||||
|
(defmethod print-object ((repetition repetition) stream)
|
||||||
|
(print-unreadable-object (repetition stream :type t :identity t)
|
||||||
|
(princ (regex repetition) stream)))
|
||||||
|
|
||||||
|
(defclass register (regex)
|
||||||
|
((regex :initarg :regex
|
||||||
|
:accessor regex
|
||||||
|
:documentation "The inner regex.")
|
||||||
|
(num :initarg :num
|
||||||
|
:reader num
|
||||||
|
:type fixnum
|
||||||
|
:documentation "The number of this register, starting from 0.
|
||||||
|
This is the index into *REGS-START* and *REGS-END*.")
|
||||||
|
(name :initarg :name
|
||||||
|
:reader name
|
||||||
|
:documentation "Name of this register or NIL."))
|
||||||
|
(:documentation "REGISTER objects represent register groups."))
|
||||||
|
|
||||||
|
(defmethod print-object ((register register) stream)
|
||||||
|
(print-unreadable-object (register stream :type t :identity t)
|
||||||
|
(princ (regex register) stream)))
|
||||||
|
|
||||||
|
(defclass standalone (regex)
|
||||||
|
((regex :initarg :regex
|
||||||
|
:accessor regex
|
||||||
|
:documentation "The inner regex."))
|
||||||
|
(:documentation "A standalone regular expression."))
|
||||||
|
|
||||||
|
(defclass back-reference (regex)
|
||||||
|
((num :initarg :num
|
||||||
|
:accessor num
|
||||||
|
:type fixnum
|
||||||
|
:documentation "The number of the register this
|
||||||
|
reference refers to.")
|
||||||
|
(name :initarg :name
|
||||||
|
:accessor name
|
||||||
|
:documentation "The name of the register this
|
||||||
|
reference refers to or NIL.")
|
||||||
|
(case-insensitive-p :initarg :case-insensitive-p
|
||||||
|
:reader case-insensitive-p
|
||||||
|
:documentation "Whether we check
|
||||||
|
case-insensitively."))
|
||||||
|
(:documentation "BACK-REFERENCE objects represent backreferences."))
|
||||||
|
|
||||||
|
(defclass char-class (regex)
|
||||||
|
((test-function :initarg :test-function
|
||||||
|
:reader test-function
|
||||||
|
:type (or function symbol nil)
|
||||||
|
:documentation "A unary function \(accepting a
|
||||||
|
character) which stands in for the character class and does the work
|
||||||
|
of checking whether a character belongs to the class."))
|
||||||
|
(:documentation "CHAR-CLASS objects represent character classes."))
|
||||||
|
|
||||||
|
(defclass str (regex)
|
||||||
|
((str :initarg :str
|
||||||
|
:accessor str
|
||||||
|
:type string
|
||||||
|
:documentation "The actual string.")
|
||||||
|
(len :initform 0
|
||||||
|
:accessor len
|
||||||
|
:type fixnum
|
||||||
|
:documentation "The length of the string.")
|
||||||
|
(case-insensitive-p :initarg :case-insensitive-p
|
||||||
|
:reader case-insensitive-p
|
||||||
|
:documentation "If we match case-insensitively.")
|
||||||
|
(offset :initform nil
|
||||||
|
:accessor offset
|
||||||
|
:documentation "Offset from the left of the whole
|
||||||
|
parse tree. The first regex has offset 0. NIL if unknown, i.e. behind
|
||||||
|
a variable-length regex.")
|
||||||
|
(skip :initform nil
|
||||||
|
:initarg :skip
|
||||||
|
:accessor skip
|
||||||
|
:documentation "If we can avoid testing for this
|
||||||
|
string because the SCAN function has done this already.")
|
||||||
|
(start-of-end-string-p :initform nil
|
||||||
|
:accessor start-of-end-string-p
|
||||||
|
:documentation "If this is the unique
|
||||||
|
STR which starts END-STRING (a slot of MATCHER)."))
|
||||||
|
(:documentation "STR objects represent string."))
|
||||||
|
|
||||||
|
(defmethod print-object ((str str) stream)
|
||||||
|
(print-unreadable-object (str stream :type t :identity t)
|
||||||
|
(princ (str str) stream)))
|
||||||
|
|
||||||
|
(defclass anchor (regex)
|
||||||
|
((startp :initarg :startp
|
||||||
|
:reader startp
|
||||||
|
:documentation "Whether this is a \"start anchor\".")
|
||||||
|
(multi-line-p :initarg :multi-line-p
|
||||||
|
:initform nil
|
||||||
|
:reader multi-line-p
|
||||||
|
:documentation "Whether we're in multi-line mode,
|
||||||
|
i.e. whether each #\\Newline is surrounded by anchors.")
|
||||||
|
(no-newline-p :initarg :no-newline-p
|
||||||
|
:initform nil
|
||||||
|
:reader no-newline-p
|
||||||
|
:documentation "Whether we ignore #\\Newline at the end."))
|
||||||
|
(:documentation "ANCHOR objects represent anchors like \"^\" or \"$\"."))
|
||||||
|
|
||||||
|
(defclass everything (regex)
|
||||||
|
((single-line-p :initarg :single-line-p
|
||||||
|
:reader single-line-p
|
||||||
|
:documentation "Whether we're in single-line mode,
|
||||||
|
i.e. whether we also match #\\Newline."))
|
||||||
|
(:documentation "EVERYTHING objects represent regexes matching
|
||||||
|
\"everything\", i.e. dots."))
|
||||||
|
|
||||||
|
(defclass word-boundary (regex)
|
||||||
|
((negatedp :initarg :negatedp
|
||||||
|
:reader negatedp
|
||||||
|
:documentation "Whether we mean the opposite,
|
||||||
|
i.e. no word-boundary."))
|
||||||
|
(:documentation "WORD-BOUNDARY objects represent word-boundary assertions."))
|
||||||
|
|
||||||
|
(defclass branch (regex)
|
||||||
|
((test :initarg :test
|
||||||
|
:accessor test
|
||||||
|
:documentation "The test of this branch, one of
|
||||||
|
LOOKAHEAD, LOOKBEHIND, or a number.")
|
||||||
|
(then-regex :initarg :then-regex
|
||||||
|
:accessor then-regex
|
||||||
|
:documentation "The regex that's to be matched if the
|
||||||
|
test succeeds.")
|
||||||
|
(else-regex :initarg :else-regex
|
||||||
|
:initform (make-instance 'void)
|
||||||
|
:accessor else-regex
|
||||||
|
:documentation "The regex that's to be matched if the
|
||||||
|
test fails."))
|
||||||
|
(:documentation "BRANCH objects represent Perl's conditional regular
|
||||||
|
expressions."))
|
||||||
|
|
||||||
|
(defclass filter (regex)
|
||||||
|
((fn :initarg :fn
|
||||||
|
:accessor fn
|
||||||
|
:type (or function symbol)
|
||||||
|
:documentation "The user-defined function.")
|
||||||
|
(len :initarg :len
|
||||||
|
:reader len
|
||||||
|
:documentation "The fixed length of this filter or NIL."))
|
||||||
|
(:documentation "FILTER objects represent arbitrary functions
|
||||||
|
defined by the user."))
|
||||||
|
|
||||||
|
(defclass void (regex)
|
||||||
|
()
|
||||||
|
(:documentation "VOID objects represent empty regular expressions."))
|
||||||
|
|
||||||
|
(defmethod initialize-instance :after ((str str) &rest init-args)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (ignore init-args))
|
||||||
|
"Automatically computes the length of a STR after initialization."
|
||||||
|
(let ((str-slot (slot-value str 'str)))
|
||||||
|
(unless (typep str-slot
|
||||||
|
#-:lispworks 'simple-string
|
||||||
|
#+:lispworks 'lw:simple-text-string)
|
||||||
|
(setf (slot-value str 'str)
|
||||||
|
(coerce str-slot
|
||||||
|
#-:lispworks 'simple-string
|
||||||
|
#+:lispworks 'lw:simple-text-string))))
|
||||||
|
(setf (len str) (length (str str))))
|
||||||
|
|
||||||
|
|
@ -0,0 +1,833 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/repetition-closures.lisp,v 1.34 2009/09/17 19:17:31 edi Exp $
|
||||||
|
|
||||||
|
;;; This is actually a part of closures.lisp which we put into a
|
||||||
|
;;; separate file because it is rather complex. We only deal with
|
||||||
|
;;; REPETITIONs here. Note that this part of the code contains some
|
||||||
|
;;; rather crazy micro-optimizations which were introduced to be as
|
||||||
|
;;; competitive with Perl as possible in tight loops.
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre)
|
||||||
|
|
||||||
|
(defmacro incf-after (place &optional (delta 1) &environment env)
|
||||||
|
"Utility macro inspired by C's \"place++\", i.e. first return the
|
||||||
|
value of PLACE and afterwards increment it by DELTA."
|
||||||
|
(with-unique-names (%temp)
|
||||||
|
(multiple-value-bind (vars vals store-vars writer-form reader-form)
|
||||||
|
(get-setf-expansion place env)
|
||||||
|
`(let* (,@(mapcar #'list vars vals)
|
||||||
|
(,%temp ,reader-form)
|
||||||
|
(,(car store-vars) (+ ,%temp ,delta)))
|
||||||
|
,writer-form
|
||||||
|
,%temp))))
|
||||||
|
|
||||||
|
;; code for greedy repetitions with minimum zero
|
||||||
|
|
||||||
|
(defmacro greedy-constant-length-closure (check-curr-pos)
|
||||||
|
"This is the template for simple greedy repetitions (where simple
|
||||||
|
means that the minimum number of repetitions is zero, that the inner
|
||||||
|
regex to be checked is of fixed length LEN, and that it doesn't
|
||||||
|
contain registers, i.e. there's no need for backtracking).
|
||||||
|
CHECK-CURR-POS is a form which checks whether the inner regex of the
|
||||||
|
repetition matches at CURR-POS."
|
||||||
|
`(if maximum
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos maximum))
|
||||||
|
;; because we know LEN we know in advance where to stop at the
|
||||||
|
;; latest; we also take into consideration MIN-REST, i.e. the
|
||||||
|
;; minimal length of the part behind the repetition
|
||||||
|
(let ((target-end-pos (min (1+ (- *end-pos* len min-rest))
|
||||||
|
;; don't go further than MAXIMUM
|
||||||
|
;; repetitions, of course
|
||||||
|
(+ start-pos
|
||||||
|
(the fixnum (* len maximum)))))
|
||||||
|
(curr-pos start-pos))
|
||||||
|
(declare (fixnum target-end-pos curr-pos))
|
||||||
|
(block greedy-constant-length-matcher
|
||||||
|
;; we use an ugly TAGBODY construct because this might be a
|
||||||
|
;; tight loop and this version is a bit faster than our LOOP
|
||||||
|
;; version (at least in CMUCL)
|
||||||
|
(tagbody
|
||||||
|
forward-loop
|
||||||
|
;; first go forward as far as possible, i.e. while
|
||||||
|
;; the inner regex matches
|
||||||
|
(when (>= curr-pos target-end-pos)
|
||||||
|
(go backward-loop))
|
||||||
|
(when ,check-curr-pos
|
||||||
|
(incf curr-pos len)
|
||||||
|
(go forward-loop))
|
||||||
|
backward-loop
|
||||||
|
;; now go back LEN steps each until we're able to match
|
||||||
|
;; the rest of the regex
|
||||||
|
(when (< curr-pos start-pos)
|
||||||
|
(return-from greedy-constant-length-matcher nil))
|
||||||
|
(let ((result (funcall next-fn curr-pos)))
|
||||||
|
(when result
|
||||||
|
(return-from greedy-constant-length-matcher result)))
|
||||||
|
(decf curr-pos len)
|
||||||
|
(go backward-loop)))))
|
||||||
|
;; basically the same code; it's just a bit easier because we're
|
||||||
|
;; not bounded by MAXIMUM
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(let ((target-end-pos (1+ (- *end-pos* len min-rest)))
|
||||||
|
(curr-pos start-pos))
|
||||||
|
(declare (fixnum target-end-pos curr-pos))
|
||||||
|
(block greedy-constant-length-matcher
|
||||||
|
(tagbody
|
||||||
|
forward-loop
|
||||||
|
(when (>= curr-pos target-end-pos)
|
||||||
|
(go backward-loop))
|
||||||
|
(when ,check-curr-pos
|
||||||
|
(incf curr-pos len)
|
||||||
|
(go forward-loop))
|
||||||
|
backward-loop
|
||||||
|
(when (< curr-pos start-pos)
|
||||||
|
(return-from greedy-constant-length-matcher nil))
|
||||||
|
(let ((result (funcall next-fn curr-pos)))
|
||||||
|
(when result
|
||||||
|
(return-from greedy-constant-length-matcher result)))
|
||||||
|
(decf curr-pos len)
|
||||||
|
(go backward-loop)))))))
|
||||||
|
|
||||||
|
(defun create-greedy-everything-matcher (maximum min-rest next-fn)
|
||||||
|
"Creates a closure which just matches as far ahead as possible,
|
||||||
|
i.e. a closure for a dot in single-line mode."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (fixnum min-rest) (function next-fn))
|
||||||
|
(if maximum
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos maximum))
|
||||||
|
;; because we know LEN we know in advance where to stop at the
|
||||||
|
;; latest; we also take into consideration MIN-REST, i.e. the
|
||||||
|
;; minimal length of the part behind the repetition
|
||||||
|
(let ((target-end-pos (min (+ start-pos maximum)
|
||||||
|
(- *end-pos* min-rest))))
|
||||||
|
(declare (fixnum target-end-pos))
|
||||||
|
;; start from the highest possible position and go backward
|
||||||
|
;; until we're able to match the rest of the regex
|
||||||
|
(loop for curr-pos of-type fixnum from target-end-pos downto start-pos
|
||||||
|
thereis (funcall next-fn curr-pos))))
|
||||||
|
;; basically the same code; it's just a bit easier because we're
|
||||||
|
;; not bounded by MAXIMUM
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(let ((target-end-pos (- *end-pos* min-rest)))
|
||||||
|
(declare (fixnum target-end-pos))
|
||||||
|
(loop for curr-pos of-type fixnum from target-end-pos downto start-pos
|
||||||
|
thereis (funcall next-fn curr-pos))))))
|
||||||
|
|
||||||
|
(defgeneric create-greedy-constant-length-matcher (repetition next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Creates a closure which tries to match REPETITION.
|
||||||
|
It is assumed that REPETITION is greedy and the minimal number of
|
||||||
|
repetitions is zero. It is furthermore assumed that the inner regex
|
||||||
|
of REPETITION is of fixed length and doesn't contain registers."))
|
||||||
|
|
||||||
|
(defmethod create-greedy-constant-length-matcher ((repetition repetition)
|
||||||
|
next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let ((len (len repetition))
|
||||||
|
(maximum (maximum repetition))
|
||||||
|
(regex (regex repetition))
|
||||||
|
(min-rest (min-rest repetition)))
|
||||||
|
(declare (fixnum len min-rest)
|
||||||
|
(function next-fn))
|
||||||
|
(cond ((zerop len)
|
||||||
|
;; inner regex has zero-length, so we can discard it
|
||||||
|
;; completely
|
||||||
|
next-fn)
|
||||||
|
(t
|
||||||
|
;; now first try to optimize for a couple of common cases
|
||||||
|
(typecase regex
|
||||||
|
(str
|
||||||
|
(let ((str (str regex)))
|
||||||
|
(if (= 1 len)
|
||||||
|
;; a single character
|
||||||
|
(let ((chr (schar str 0)))
|
||||||
|
(if (case-insensitive-p regex)
|
||||||
|
(greedy-constant-length-closure
|
||||||
|
(char-equal chr (schar *string* curr-pos)))
|
||||||
|
(greedy-constant-length-closure
|
||||||
|
(char= chr (schar *string* curr-pos)))))
|
||||||
|
;; a string
|
||||||
|
(if (case-insensitive-p regex)
|
||||||
|
(greedy-constant-length-closure
|
||||||
|
(*string*-equal str curr-pos (+ curr-pos len) 0 len))
|
||||||
|
(greedy-constant-length-closure
|
||||||
|
(*string*= str curr-pos (+ curr-pos len) 0 len))))))
|
||||||
|
(char-class
|
||||||
|
;; a character class
|
||||||
|
(insert-char-class-tester (regex (schar *string* curr-pos))
|
||||||
|
(greedy-constant-length-closure
|
||||||
|
(char-class-test))))
|
||||||
|
(everything
|
||||||
|
;; an EVERYTHING object, i.e. a dot
|
||||||
|
(if (single-line-p regex)
|
||||||
|
(create-greedy-everything-matcher maximum min-rest next-fn)
|
||||||
|
(greedy-constant-length-closure
|
||||||
|
(char/= #\Newline (schar *string* curr-pos)))))
|
||||||
|
(t
|
||||||
|
;; the general case - we build an inner matcher which
|
||||||
|
;; just checks for immediate success, i.e. NEXT-FN is
|
||||||
|
;; #'IDENTITY
|
||||||
|
(let ((inner-matcher (create-matcher-aux regex #'identity)))
|
||||||
|
(declare (function inner-matcher))
|
||||||
|
(greedy-constant-length-closure
|
||||||
|
(funcall inner-matcher curr-pos)))))))))
|
||||||
|
|
||||||
|
(defgeneric create-greedy-no-zero-matcher (repetition next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Creates a closure which tries to match REPETITION.
|
||||||
|
It is assumed that REPETITION is greedy and the minimal number of
|
||||||
|
repetitions is zero. It is furthermore assumed that the inner regex
|
||||||
|
of REPETITION can never match a zero-length string \(or instead the
|
||||||
|
maximal number of repetitions is 1)."))
|
||||||
|
|
||||||
|
(defmethod create-greedy-no-zero-matcher ((repetition repetition) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let ((maximum (maximum repetition))
|
||||||
|
;; REPEAT-MATCHER is part of the closure's environment but it
|
||||||
|
;; can only be defined after GREEDY-AUX is defined
|
||||||
|
repeat-matcher)
|
||||||
|
(declare (function next-fn))
|
||||||
|
(cond
|
||||||
|
((eql maximum 1)
|
||||||
|
;; this is essentially like the next case but with a known
|
||||||
|
;; MAXIMUM of 1 we can get away without a counter; note that
|
||||||
|
;; we always arrive here if CONVERT optimizes <regex>* to
|
||||||
|
;; (?:<regex'>*<regex>)?
|
||||||
|
(setq repeat-matcher
|
||||||
|
(create-matcher-aux (regex repetition) next-fn))
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (function repeat-matcher))
|
||||||
|
(or (funcall repeat-matcher start-pos)
|
||||||
|
(funcall next-fn start-pos))))
|
||||||
|
(maximum
|
||||||
|
;; we make a reservation for our slot in *REPEAT-COUNTERS*
|
||||||
|
;; because we need to keep track whether we've reached MAXIMUM
|
||||||
|
;; repetitions
|
||||||
|
(let ((rep-num (incf-after *rep-num*)))
|
||||||
|
(flet ((greedy-aux (start-pos)
|
||||||
|
(declare (fixnum start-pos maximum rep-num)
|
||||||
|
(function repeat-matcher))
|
||||||
|
;; the actual matcher which first tries to match the
|
||||||
|
;; inner regex of REPETITION (if we haven't done so
|
||||||
|
;; too often) and on failure calls NEXT-FN
|
||||||
|
(or (and (< (aref *repeat-counters* rep-num) maximum)
|
||||||
|
(incf (aref *repeat-counters* rep-num))
|
||||||
|
;; note that REPEAT-MATCHER will call
|
||||||
|
;; GREEDY-AUX again recursively
|
||||||
|
(prog1
|
||||||
|
(funcall repeat-matcher start-pos)
|
||||||
|
(decf (aref *repeat-counters* rep-num))))
|
||||||
|
(funcall next-fn start-pos))))
|
||||||
|
;; create a closure to match the inner regex and to
|
||||||
|
;; implement backtracking via GREEDY-AUX
|
||||||
|
(setq repeat-matcher
|
||||||
|
(create-matcher-aux (regex repetition) #'greedy-aux))
|
||||||
|
;; the closure we return is just a thin wrapper around
|
||||||
|
;; GREEDY-AUX to initialize the repetition counter
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(setf (aref *repeat-counters* rep-num) 0)
|
||||||
|
(greedy-aux start-pos)))))
|
||||||
|
(t
|
||||||
|
;; easier code because we're not bounded by MAXIMUM, but
|
||||||
|
;; basically the same
|
||||||
|
(flet ((greedy-aux (start-pos)
|
||||||
|
(declare (fixnum start-pos)
|
||||||
|
(function repeat-matcher))
|
||||||
|
(or (funcall repeat-matcher start-pos)
|
||||||
|
(funcall next-fn start-pos))))
|
||||||
|
(setq repeat-matcher
|
||||||
|
(create-matcher-aux (regex repetition) #'greedy-aux))
|
||||||
|
#'greedy-aux)))))
|
||||||
|
|
||||||
|
(defgeneric create-greedy-matcher (repetition next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Creates a closure which tries to match REPETITION.
|
||||||
|
It is assumed that REPETITION is greedy and the minimal number of
|
||||||
|
repetitions is zero."))
|
||||||
|
|
||||||
|
(defmethod create-greedy-matcher ((repetition repetition) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let ((maximum (maximum repetition))
|
||||||
|
;; we make a reservation for our slot in *LAST-POS-STORES* because
|
||||||
|
;; we have to watch out for endless loops as the inner regex might
|
||||||
|
;; match zero-length strings
|
||||||
|
(zero-length-num (incf-after *zero-length-num*))
|
||||||
|
;; REPEAT-MATCHER is part of the closure's environment but it
|
||||||
|
;; can only be defined after GREEDY-AUX is defined
|
||||||
|
repeat-matcher)
|
||||||
|
(declare (fixnum zero-length-num)
|
||||||
|
(function next-fn))
|
||||||
|
(cond
|
||||||
|
(maximum
|
||||||
|
;; we make a reservation for our slot in *REPEAT-COUNTERS*
|
||||||
|
;; because we need to keep track whether we've reached MAXIMUM
|
||||||
|
;; repetitions
|
||||||
|
(let ((rep-num (incf-after *rep-num*)))
|
||||||
|
(flet ((greedy-aux (start-pos)
|
||||||
|
;; the actual matcher which first tries to match the
|
||||||
|
;; inner regex of REPETITION (if we haven't done so
|
||||||
|
;; too often) and on failure calls NEXT-FN
|
||||||
|
(declare (fixnum start-pos maximum rep-num)
|
||||||
|
(function repeat-matcher))
|
||||||
|
(let ((old-last-pos
|
||||||
|
(svref *last-pos-stores* zero-length-num)))
|
||||||
|
(when (and old-last-pos
|
||||||
|
(= (the fixnum old-last-pos) start-pos))
|
||||||
|
;; stop immediately if we've been here before,
|
||||||
|
;; i.e. if the last attempt matched a zero-length
|
||||||
|
;; string
|
||||||
|
(return-from greedy-aux (funcall next-fn start-pos)))
|
||||||
|
;; otherwise remember this position for the next
|
||||||
|
;; repetition
|
||||||
|
(setf (svref *last-pos-stores* zero-length-num) start-pos)
|
||||||
|
(or (and (< (aref *repeat-counters* rep-num) maximum)
|
||||||
|
(incf (aref *repeat-counters* rep-num))
|
||||||
|
;; note that REPEAT-MATCHER will call
|
||||||
|
;; GREEDY-AUX again recursively
|
||||||
|
(prog1
|
||||||
|
(funcall repeat-matcher start-pos)
|
||||||
|
(decf (aref *repeat-counters* rep-num))
|
||||||
|
(setf (svref *last-pos-stores* zero-length-num)
|
||||||
|
old-last-pos)))
|
||||||
|
(funcall next-fn start-pos)))))
|
||||||
|
;; create a closure to match the inner regex and to
|
||||||
|
;; implement backtracking via GREEDY-AUX
|
||||||
|
(setq repeat-matcher
|
||||||
|
(create-matcher-aux (regex repetition) #'greedy-aux))
|
||||||
|
;; the closure we return is just a thin wrapper around
|
||||||
|
;; GREEDY-AUX to initialize the repetition counter and our
|
||||||
|
;; slot in *LAST-POS-STORES*
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(setf (aref *repeat-counters* rep-num) 0
|
||||||
|
(svref *last-pos-stores* zero-length-num) nil)
|
||||||
|
(greedy-aux start-pos)))))
|
||||||
|
(t
|
||||||
|
;; easier code because we're not bounded by MAXIMUM, but
|
||||||
|
;; basically the same
|
||||||
|
(flet ((greedy-aux (start-pos)
|
||||||
|
(declare (fixnum start-pos)
|
||||||
|
(function repeat-matcher))
|
||||||
|
(let ((old-last-pos
|
||||||
|
(svref *last-pos-stores* zero-length-num)))
|
||||||
|
(when (and old-last-pos
|
||||||
|
(= (the fixnum old-last-pos) start-pos))
|
||||||
|
(return-from greedy-aux (funcall next-fn start-pos)))
|
||||||
|
(setf (svref *last-pos-stores* zero-length-num) start-pos)
|
||||||
|
(or (prog1
|
||||||
|
(funcall repeat-matcher start-pos)
|
||||||
|
(setf (svref *last-pos-stores* zero-length-num) old-last-pos))
|
||||||
|
(funcall next-fn start-pos)))))
|
||||||
|
(setq repeat-matcher
|
||||||
|
(create-matcher-aux (regex repetition) #'greedy-aux))
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(setf (svref *last-pos-stores* zero-length-num) nil)
|
||||||
|
(greedy-aux start-pos)))))))
|
||||||
|
|
||||||
|
;; code for non-greedy repetitions with minimum zero
|
||||||
|
|
||||||
|
(defmacro non-greedy-constant-length-closure (check-curr-pos)
|
||||||
|
"This is the template for simple non-greedy repetitions \(where
|
||||||
|
simple means that the minimum number of repetitions is zero, that the
|
||||||
|
inner regex to be checked is of fixed length LEN, and that it doesn't
|
||||||
|
contain registers, i.e. there's no need for backtracking).
|
||||||
|
CHECK-CURR-POS is a form which checks whether the inner regex of the
|
||||||
|
repetition matches at CURR-POS."
|
||||||
|
`(if maximum
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos maximum))
|
||||||
|
;; because we know LEN we know in advance where to stop at the
|
||||||
|
;; latest; we also take into consideration MIN-REST, i.e. the
|
||||||
|
;; minimal length of the part behind the repetition
|
||||||
|
(let ((target-end-pos (min (1+ (- *end-pos* len min-rest))
|
||||||
|
(+ start-pos
|
||||||
|
(the fixnum (* len maximum))))))
|
||||||
|
;; move forward by LEN and always try NEXT-FN first, then
|
||||||
|
;; CHECK-CUR-POS
|
||||||
|
(loop for curr-pos of-type fixnum from start-pos
|
||||||
|
below target-end-pos
|
||||||
|
by len
|
||||||
|
thereis (funcall next-fn curr-pos)
|
||||||
|
while ,check-curr-pos
|
||||||
|
finally (return (funcall next-fn curr-pos)))))
|
||||||
|
;; basically the same code; it's just a bit easier because we're
|
||||||
|
;; not bounded by MAXIMUM
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(let ((target-end-pos (1+ (- *end-pos* len min-rest))))
|
||||||
|
(loop for curr-pos of-type fixnum from start-pos
|
||||||
|
below target-end-pos
|
||||||
|
by len
|
||||||
|
thereis (funcall next-fn curr-pos)
|
||||||
|
while ,check-curr-pos
|
||||||
|
finally (return (funcall next-fn curr-pos)))))))
|
||||||
|
|
||||||
|
(defgeneric create-non-greedy-constant-length-matcher (repetition next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Creates a closure which tries to match REPETITION.
|
||||||
|
It is assumed that REPETITION is non-greedy and the minimal number of
|
||||||
|
repetitions is zero. It is furthermore assumed that the inner regex
|
||||||
|
of REPETITION is of fixed length and doesn't contain registers."))
|
||||||
|
|
||||||
|
(defmethod create-non-greedy-constant-length-matcher ((repetition repetition) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let ((len (len repetition))
|
||||||
|
(maximum (maximum repetition))
|
||||||
|
(regex (regex repetition))
|
||||||
|
(min-rest (min-rest repetition)))
|
||||||
|
(declare (fixnum len min-rest)
|
||||||
|
(function next-fn))
|
||||||
|
(cond ((zerop len)
|
||||||
|
;; inner regex has zero-length, so we can discard it
|
||||||
|
;; completely
|
||||||
|
next-fn)
|
||||||
|
(t
|
||||||
|
;; now first try to optimize for a couple of common cases
|
||||||
|
(typecase regex
|
||||||
|
(str
|
||||||
|
(let ((str (str regex)))
|
||||||
|
(if (= 1 len)
|
||||||
|
;; a single character
|
||||||
|
(let ((chr (schar str 0)))
|
||||||
|
(if (case-insensitive-p regex)
|
||||||
|
(non-greedy-constant-length-closure
|
||||||
|
(char-equal chr (schar *string* curr-pos)))
|
||||||
|
(non-greedy-constant-length-closure
|
||||||
|
(char= chr (schar *string* curr-pos)))))
|
||||||
|
;; a string
|
||||||
|
(if (case-insensitive-p regex)
|
||||||
|
(non-greedy-constant-length-closure
|
||||||
|
(*string*-equal str curr-pos (+ curr-pos len) 0 len))
|
||||||
|
(non-greedy-constant-length-closure
|
||||||
|
(*string*= str curr-pos (+ curr-pos len) 0 len))))))
|
||||||
|
(char-class
|
||||||
|
;; a character class
|
||||||
|
(insert-char-class-tester (regex (schar *string* curr-pos))
|
||||||
|
(non-greedy-constant-length-closure
|
||||||
|
(char-class-test))))
|
||||||
|
(everything
|
||||||
|
(if (single-line-p regex)
|
||||||
|
;; a dot which really can match everything; we rely
|
||||||
|
;; on the compiler to optimize this away
|
||||||
|
(non-greedy-constant-length-closure
|
||||||
|
t)
|
||||||
|
;; a dot which has to watch out for #\Newline
|
||||||
|
(non-greedy-constant-length-closure
|
||||||
|
(char/= #\Newline (schar *string* curr-pos)))))
|
||||||
|
(t
|
||||||
|
;; the general case - we build an inner matcher which
|
||||||
|
;; just checks for immediate success, i.e. NEXT-FN is
|
||||||
|
;; #'IDENTITY
|
||||||
|
(let ((inner-matcher (create-matcher-aux regex #'identity)))
|
||||||
|
(declare (function inner-matcher))
|
||||||
|
(non-greedy-constant-length-closure
|
||||||
|
(funcall inner-matcher curr-pos)))))))))
|
||||||
|
|
||||||
|
(defgeneric create-non-greedy-no-zero-matcher (repetition next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Creates a closure which tries to match REPETITION.
|
||||||
|
It is assumed that REPETITION is non-greedy and the minimal number of
|
||||||
|
repetitions is zero. It is furthermore assumed that the inner regex
|
||||||
|
of REPETITION can never match a zero-length string \(or instead the
|
||||||
|
maximal number of repetitions is 1)."))
|
||||||
|
|
||||||
|
(defmethod create-non-greedy-no-zero-matcher ((repetition repetition) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let ((maximum (maximum repetition))
|
||||||
|
;; REPEAT-MATCHER is part of the closure's environment but it
|
||||||
|
;; can only be defined after NON-GREEDY-AUX is defined
|
||||||
|
repeat-matcher)
|
||||||
|
(declare (function next-fn))
|
||||||
|
(cond
|
||||||
|
((eql maximum 1)
|
||||||
|
;; this is essentially like the next case but with a known
|
||||||
|
;; MAXIMUM of 1 we can get away without a counter
|
||||||
|
(setq repeat-matcher
|
||||||
|
(create-matcher-aux (regex repetition) next-fn))
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (function repeat-matcher))
|
||||||
|
(or (funcall next-fn start-pos)
|
||||||
|
(funcall repeat-matcher start-pos))))
|
||||||
|
(maximum
|
||||||
|
;; we make a reservation for our slot in *REPEAT-COUNTERS*
|
||||||
|
;; because we need to keep track whether we've reached MAXIMUM
|
||||||
|
;; repetitions
|
||||||
|
(let ((rep-num (incf-after *rep-num*)))
|
||||||
|
(flet ((non-greedy-aux (start-pos)
|
||||||
|
;; the actual matcher which first calls NEXT-FN and
|
||||||
|
;; on failure tries to match the inner regex of
|
||||||
|
;; REPETITION (if we haven't done so too often)
|
||||||
|
(declare (fixnum start-pos maximum rep-num)
|
||||||
|
(function repeat-matcher))
|
||||||
|
(or (funcall next-fn start-pos)
|
||||||
|
(and (< (aref *repeat-counters* rep-num) maximum)
|
||||||
|
(incf (aref *repeat-counters* rep-num))
|
||||||
|
;; note that REPEAT-MATCHER will call
|
||||||
|
;; NON-GREEDY-AUX again recursively
|
||||||
|
(prog1
|
||||||
|
(funcall repeat-matcher start-pos)
|
||||||
|
(decf (aref *repeat-counters* rep-num)))))))
|
||||||
|
;; create a closure to match the inner regex and to
|
||||||
|
;; implement backtracking via NON-GREEDY-AUX
|
||||||
|
(setq repeat-matcher
|
||||||
|
(create-matcher-aux (regex repetition) #'non-greedy-aux))
|
||||||
|
;; the closure we return is just a thin wrapper around
|
||||||
|
;; NON-GREEDY-AUX to initialize the repetition counter
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(setf (aref *repeat-counters* rep-num) 0)
|
||||||
|
(non-greedy-aux start-pos)))))
|
||||||
|
(t
|
||||||
|
;; easier code because we're not bounded by MAXIMUM, but
|
||||||
|
;; basically the same
|
||||||
|
(flet ((non-greedy-aux (start-pos)
|
||||||
|
(declare (fixnum start-pos)
|
||||||
|
(function repeat-matcher))
|
||||||
|
(or (funcall next-fn start-pos)
|
||||||
|
(funcall repeat-matcher start-pos))))
|
||||||
|
(setq repeat-matcher
|
||||||
|
(create-matcher-aux (regex repetition) #'non-greedy-aux))
|
||||||
|
#'non-greedy-aux)))))
|
||||||
|
|
||||||
|
(defgeneric create-non-greedy-matcher (repetition next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Creates a closure which tries to match REPETITION.
|
||||||
|
It is assumed that REPETITION is non-greedy and the minimal number of
|
||||||
|
repetitions is zero."))
|
||||||
|
|
||||||
|
(defmethod create-non-greedy-matcher ((repetition repetition) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; we make a reservation for our slot in *LAST-POS-STORES* because
|
||||||
|
;; we have to watch out for endless loops as the inner regex might
|
||||||
|
;; match zero-length strings
|
||||||
|
(let ((zero-length-num (incf-after *zero-length-num*))
|
||||||
|
(maximum (maximum repetition))
|
||||||
|
;; REPEAT-MATCHER is part of the closure's environment but it
|
||||||
|
;; can only be defined after NON-GREEDY-AUX is defined
|
||||||
|
repeat-matcher)
|
||||||
|
(declare (fixnum zero-length-num)
|
||||||
|
(function next-fn))
|
||||||
|
(cond
|
||||||
|
(maximum
|
||||||
|
;; we make a reservation for our slot in *REPEAT-COUNTERS*
|
||||||
|
;; because we need to keep track whether we've reached MAXIMUM
|
||||||
|
;; repetitions
|
||||||
|
(let ((rep-num (incf-after *rep-num*)))
|
||||||
|
(flet ((non-greedy-aux (start-pos)
|
||||||
|
;; the actual matcher which first calls NEXT-FN and
|
||||||
|
;; on failure tries to match the inner regex of
|
||||||
|
;; REPETITION (if we haven't done so too often)
|
||||||
|
(declare (fixnum start-pos maximum rep-num)
|
||||||
|
(function repeat-matcher))
|
||||||
|
(let ((old-last-pos
|
||||||
|
(svref *last-pos-stores* zero-length-num)))
|
||||||
|
(when (and old-last-pos
|
||||||
|
(= (the fixnum old-last-pos) start-pos))
|
||||||
|
;; stop immediately if we've been here before,
|
||||||
|
;; i.e. if the last attempt matched a zero-length
|
||||||
|
;; string
|
||||||
|
(return-from non-greedy-aux (funcall next-fn start-pos)))
|
||||||
|
;; otherwise remember this position for the next
|
||||||
|
;; repetition
|
||||||
|
(setf (svref *last-pos-stores* zero-length-num) start-pos)
|
||||||
|
(or (funcall next-fn start-pos)
|
||||||
|
(and (< (aref *repeat-counters* rep-num) maximum)
|
||||||
|
(incf (aref *repeat-counters* rep-num))
|
||||||
|
;; note that REPEAT-MATCHER will call
|
||||||
|
;; NON-GREEDY-AUX again recursively
|
||||||
|
(prog1
|
||||||
|
(funcall repeat-matcher start-pos)
|
||||||
|
(decf (aref *repeat-counters* rep-num))
|
||||||
|
(setf (svref *last-pos-stores* zero-length-num)
|
||||||
|
old-last-pos)))))))
|
||||||
|
;; create a closure to match the inner regex and to
|
||||||
|
;; implement backtracking via NON-GREEDY-AUX
|
||||||
|
(setq repeat-matcher
|
||||||
|
(create-matcher-aux (regex repetition) #'non-greedy-aux))
|
||||||
|
;; the closure we return is just a thin wrapper around
|
||||||
|
;; NON-GREEDY-AUX to initialize the repetition counter and our
|
||||||
|
;; slot in *LAST-POS-STORES*
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(setf (aref *repeat-counters* rep-num) 0
|
||||||
|
(svref *last-pos-stores* zero-length-num) nil)
|
||||||
|
(non-greedy-aux start-pos)))))
|
||||||
|
(t
|
||||||
|
;; easier code because we're not bounded by MAXIMUM, but
|
||||||
|
;; basically the same
|
||||||
|
(flet ((non-greedy-aux (start-pos)
|
||||||
|
(declare (fixnum start-pos)
|
||||||
|
(function repeat-matcher))
|
||||||
|
(let ((old-last-pos
|
||||||
|
(svref *last-pos-stores* zero-length-num)))
|
||||||
|
(when (and old-last-pos
|
||||||
|
(= (the fixnum old-last-pos) start-pos))
|
||||||
|
(return-from non-greedy-aux (funcall next-fn start-pos)))
|
||||||
|
(setf (svref *last-pos-stores* zero-length-num) start-pos)
|
||||||
|
(or (funcall next-fn start-pos)
|
||||||
|
(prog1
|
||||||
|
(funcall repeat-matcher start-pos)
|
||||||
|
(setf (svref *last-pos-stores* zero-length-num)
|
||||||
|
old-last-pos))))))
|
||||||
|
(setq repeat-matcher
|
||||||
|
(create-matcher-aux (regex repetition) #'non-greedy-aux))
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(setf (svref *last-pos-stores* zero-length-num) nil)
|
||||||
|
(non-greedy-aux start-pos)))))))
|
||||||
|
|
||||||
|
;; code for constant repetitions, i.e. those with a fixed number of repetitions
|
||||||
|
|
||||||
|
(defmacro constant-repetition-constant-length-closure (check-curr-pos)
|
||||||
|
"This is the template for simple constant repetitions (where simple
|
||||||
|
means that the inner regex to be checked is of fixed length LEN, and
|
||||||
|
that it doesn't contain registers, i.e. there's no need for
|
||||||
|
backtracking) and where constant means that MINIMUM is equal to
|
||||||
|
MAXIMUM. CHECK-CURR-POS is a form which checks whether the inner
|
||||||
|
regex of the repetition matches at CURR-POS."
|
||||||
|
`(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(let ((target-end-pos (+ start-pos
|
||||||
|
(the fixnum (* len repetitions)))))
|
||||||
|
(declare (fixnum target-end-pos))
|
||||||
|
;; first check if we won't go beyond the end of the string
|
||||||
|
(and (>= *end-pos* target-end-pos)
|
||||||
|
;; then loop through all repetitions step by step
|
||||||
|
(loop for curr-pos of-type fixnum from start-pos
|
||||||
|
below target-end-pos
|
||||||
|
by len
|
||||||
|
always ,check-curr-pos)
|
||||||
|
;; finally call NEXT-FN if we made it that far
|
||||||
|
(funcall next-fn target-end-pos)))))
|
||||||
|
|
||||||
|
(defgeneric create-constant-repetition-constant-length-matcher
|
||||||
|
(repetition next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Creates a closure which tries to match REPETITION.
|
||||||
|
It is assumed that REPETITION has a constant number of repetitions.
|
||||||
|
It is furthermore assumed that the inner regex of REPETITION is of
|
||||||
|
fixed length and doesn't contain registers."))
|
||||||
|
|
||||||
|
(defmethod create-constant-repetition-constant-length-matcher
|
||||||
|
((repetition repetition) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let ((len (len repetition))
|
||||||
|
(repetitions (minimum repetition))
|
||||||
|
(regex (regex repetition)))
|
||||||
|
(declare (fixnum len repetitions)
|
||||||
|
(function next-fn))
|
||||||
|
(if (zerop len)
|
||||||
|
;; if the length is zero it suffices to try once
|
||||||
|
(create-matcher-aux regex next-fn)
|
||||||
|
;; otherwise try to optimize for a couple of common cases
|
||||||
|
(typecase regex
|
||||||
|
(str
|
||||||
|
(let ((str (str regex)))
|
||||||
|
(if (= 1 len)
|
||||||
|
;; a single character
|
||||||
|
(let ((chr (schar str 0)))
|
||||||
|
(if (case-insensitive-p regex)
|
||||||
|
(constant-repetition-constant-length-closure
|
||||||
|
(and (char-equal chr (schar *string* curr-pos))
|
||||||
|
(1+ curr-pos)))
|
||||||
|
(constant-repetition-constant-length-closure
|
||||||
|
(and (char= chr (schar *string* curr-pos))
|
||||||
|
(1+ curr-pos)))))
|
||||||
|
;; a string
|
||||||
|
(if (case-insensitive-p regex)
|
||||||
|
(constant-repetition-constant-length-closure
|
||||||
|
(let ((next-pos (+ curr-pos len)))
|
||||||
|
(declare (fixnum next-pos))
|
||||||
|
(and (*string*-equal str curr-pos next-pos 0 len)
|
||||||
|
next-pos)))
|
||||||
|
(constant-repetition-constant-length-closure
|
||||||
|
(let ((next-pos (+ curr-pos len)))
|
||||||
|
(declare (fixnum next-pos))
|
||||||
|
(and (*string*= str curr-pos next-pos 0 len)
|
||||||
|
next-pos)))))))
|
||||||
|
(char-class
|
||||||
|
;; a character class
|
||||||
|
(insert-char-class-tester (regex (schar *string* curr-pos))
|
||||||
|
(constant-repetition-constant-length-closure
|
||||||
|
(and (char-class-test)
|
||||||
|
(1+ curr-pos)))))
|
||||||
|
(everything
|
||||||
|
(if (single-line-p regex)
|
||||||
|
;; a dot which really matches everything - we just have to
|
||||||
|
;; advance the index into *STRING* accordingly and check
|
||||||
|
;; if we didn't go past the end
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(let ((next-pos (+ start-pos repetitions)))
|
||||||
|
(declare (fixnum next-pos))
|
||||||
|
(and (<= next-pos *end-pos*)
|
||||||
|
(funcall next-fn next-pos))))
|
||||||
|
;; a dot which is not in single-line-mode - make sure we
|
||||||
|
;; don't match #\Newline
|
||||||
|
(constant-repetition-constant-length-closure
|
||||||
|
(and (char/= #\Newline (schar *string* curr-pos))
|
||||||
|
(1+ curr-pos)))))
|
||||||
|
(t
|
||||||
|
;; the general case - we build an inner matcher which just
|
||||||
|
;; checks for immediate success, i.e. NEXT-FN is #'IDENTITY
|
||||||
|
(let ((inner-matcher (create-matcher-aux regex #'identity)))
|
||||||
|
(declare (function inner-matcher))
|
||||||
|
(constant-repetition-constant-length-closure
|
||||||
|
(funcall inner-matcher curr-pos))))))))
|
||||||
|
|
||||||
|
(defgeneric create-constant-repetition-matcher (repetition next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(:documentation "Creates a closure which tries to match REPETITION.
|
||||||
|
It is assumed that REPETITION has a constant number of repetitions."))
|
||||||
|
|
||||||
|
(defmethod create-constant-repetition-matcher ((repetition repetition) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(let ((repetitions (minimum repetition))
|
||||||
|
;; we make a reservation for our slot in *REPEAT-COUNTERS*
|
||||||
|
;; because we need to keep track of the number of repetitions
|
||||||
|
(rep-num (incf-after *rep-num*))
|
||||||
|
;; REPEAT-MATCHER is part of the closure's environment but it
|
||||||
|
;; can only be defined after NON-GREEDY-AUX is defined
|
||||||
|
repeat-matcher)
|
||||||
|
(declare (fixnum repetitions rep-num)
|
||||||
|
(function next-fn))
|
||||||
|
(if (zerop (min-len repetition))
|
||||||
|
;; we make a reservation for our slot in *LAST-POS-STORES*
|
||||||
|
;; because we have to watch out for needless loops as the inner
|
||||||
|
;; regex might match zero-length strings
|
||||||
|
(let ((zero-length-num (incf-after *zero-length-num*)))
|
||||||
|
(declare (fixnum zero-length-num))
|
||||||
|
(flet ((constant-aux (start-pos)
|
||||||
|
;; the actual matcher which first calls NEXT-FN and
|
||||||
|
;; on failure tries to match the inner regex of
|
||||||
|
;; REPETITION (if we haven't done so too often)
|
||||||
|
(declare (fixnum start-pos)
|
||||||
|
(function repeat-matcher))
|
||||||
|
(let ((old-last-pos
|
||||||
|
(svref *last-pos-stores* zero-length-num)))
|
||||||
|
(when (and old-last-pos
|
||||||
|
(= (the fixnum old-last-pos) start-pos))
|
||||||
|
;; if we've been here before we matched a
|
||||||
|
;; zero-length string the last time, so we can
|
||||||
|
;; just carry on because we will definitely be
|
||||||
|
;; able to do this again often enough
|
||||||
|
(return-from constant-aux (funcall next-fn start-pos)))
|
||||||
|
;; otherwise remember this position for the next
|
||||||
|
;; repetition
|
||||||
|
(setf (svref *last-pos-stores* zero-length-num) start-pos)
|
||||||
|
(cond ((< (aref *repeat-counters* rep-num) repetitions)
|
||||||
|
;; not enough repetitions yet, try it again
|
||||||
|
(incf (aref *repeat-counters* rep-num))
|
||||||
|
;; note that REPEAT-MATCHER will call
|
||||||
|
;; CONSTANT-AUX again recursively
|
||||||
|
(prog1
|
||||||
|
(funcall repeat-matcher start-pos)
|
||||||
|
(decf (aref *repeat-counters* rep-num))
|
||||||
|
(setf (svref *last-pos-stores* zero-length-num)
|
||||||
|
old-last-pos)))
|
||||||
|
(t
|
||||||
|
;; we're done - call NEXT-FN
|
||||||
|
(funcall next-fn start-pos))))))
|
||||||
|
;; create a closure to match the inner regex and to
|
||||||
|
;; implement backtracking via CONSTANT-AUX
|
||||||
|
(setq repeat-matcher
|
||||||
|
(create-matcher-aux (regex repetition) #'constant-aux))
|
||||||
|
;; the closure we return is just a thin wrapper around
|
||||||
|
;; CONSTANT-AUX to initialize the repetition counter
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(setf (aref *repeat-counters* rep-num) 0
|
||||||
|
(aref *last-pos-stores* zero-length-num) nil)
|
||||||
|
(constant-aux start-pos))))
|
||||||
|
;; easier code because we don't have to care about zero-length
|
||||||
|
;; matches but basically the same
|
||||||
|
(flet ((constant-aux (start-pos)
|
||||||
|
(declare (fixnum start-pos)
|
||||||
|
(function repeat-matcher))
|
||||||
|
(cond ((< (aref *repeat-counters* rep-num) repetitions)
|
||||||
|
(incf (aref *repeat-counters* rep-num))
|
||||||
|
(prog1
|
||||||
|
(funcall repeat-matcher start-pos)
|
||||||
|
(decf (aref *repeat-counters* rep-num))))
|
||||||
|
(t (funcall next-fn start-pos)))))
|
||||||
|
(setq repeat-matcher
|
||||||
|
(create-matcher-aux (regex repetition) #'constant-aux))
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(setf (aref *repeat-counters* rep-num) 0)
|
||||||
|
(constant-aux start-pos))))))
|
||||||
|
|
||||||
|
;; the actual CREATE-MATCHER-AUX method for REPETITION objects which
|
||||||
|
;; utilizes all the functions and macros defined above
|
||||||
|
|
||||||
|
(defmethod create-matcher-aux ((repetition repetition) next-fn)
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(with-slots (minimum maximum len min-len greedyp contains-register-p)
|
||||||
|
repetition
|
||||||
|
(cond ((and maximum
|
||||||
|
(zerop maximum))
|
||||||
|
;; this should have been optimized away by CONVERT but just
|
||||||
|
;; in case...
|
||||||
|
(error "Got REPETITION with MAXIMUM 0 \(should not happen)"))
|
||||||
|
((and maximum
|
||||||
|
(= minimum maximum 1))
|
||||||
|
;; this should have been optimized away by CONVERT but just
|
||||||
|
;; in case...
|
||||||
|
(error "Got REPETITION with MAXIMUM 1 and MINIMUM 1 \(should not happen)"))
|
||||||
|
((and (eql minimum maximum)
|
||||||
|
len
|
||||||
|
(not contains-register-p))
|
||||||
|
(create-constant-repetition-constant-length-matcher repetition next-fn))
|
||||||
|
((eql minimum maximum)
|
||||||
|
(create-constant-repetition-matcher repetition next-fn))
|
||||||
|
((and greedyp
|
||||||
|
len
|
||||||
|
(not contains-register-p))
|
||||||
|
(create-greedy-constant-length-matcher repetition next-fn))
|
||||||
|
((and greedyp
|
||||||
|
(or (plusp min-len)
|
||||||
|
(eql maximum 1)))
|
||||||
|
(create-greedy-no-zero-matcher repetition next-fn))
|
||||||
|
(greedyp
|
||||||
|
(create-greedy-matcher repetition next-fn))
|
||||||
|
((and len
|
||||||
|
(plusp len)
|
||||||
|
(not contains-register-p))
|
||||||
|
(create-non-greedy-constant-length-matcher repetition next-fn))
|
||||||
|
((or (plusp min-len)
|
||||||
|
(eql maximum 1))
|
||||||
|
(create-non-greedy-no-zero-matcher repetition next-fn))
|
||||||
|
(t
|
||||||
|
(create-non-greedy-matcher repetition next-fn)))))
|
||||||
|
|
@ -0,0 +1,506 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/scanner.lisp,v 1.36 2009/09/17 19:17:31 edi Exp $
|
||||||
|
|
||||||
|
;;; Here the scanner for the actual regex as well as utility scanners
|
||||||
|
;;; for the constant start and end strings are created.
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre)
|
||||||
|
|
||||||
|
(defmacro bmh-matcher-aux (&key case-insensitive-p)
|
||||||
|
"Auxiliary macro used by CREATE-BMH-MATCHER."
|
||||||
|
(let ((char-compare (if case-insensitive-p 'char-equal 'char=)))
|
||||||
|
`(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(if (or (minusp start-pos)
|
||||||
|
(> (the fixnum (+ start-pos m)) *end-pos*))
|
||||||
|
nil
|
||||||
|
(loop named bmh-matcher
|
||||||
|
for k of-type fixnum = (+ start-pos m -1)
|
||||||
|
then (+ k (max 1 (aref skip (char-code (schar *string* k)))))
|
||||||
|
while (< k *end-pos*)
|
||||||
|
do (loop for j of-type fixnum downfrom (1- m)
|
||||||
|
for i of-type fixnum downfrom k
|
||||||
|
while (and (>= j 0)
|
||||||
|
(,char-compare (schar *string* i)
|
||||||
|
(schar pattern j)))
|
||||||
|
finally (if (minusp j)
|
||||||
|
(return-from bmh-matcher (1+ i)))))))))
|
||||||
|
|
||||||
|
(defun create-bmh-matcher (pattern case-insensitive-p)
|
||||||
|
"Returns a Boyer-Moore-Horspool matcher which searches the (special)
|
||||||
|
simple-string *STRING* for the first occurence of the substring
|
||||||
|
PATTERN. The search starts at the position START-POS within *STRING*
|
||||||
|
and stops before *END-POS* is reached. Depending on the second
|
||||||
|
argument the search is case-insensitive or not. If the special
|
||||||
|
variable *USE-BMH-MATCHERS* is NIL, use the standard SEARCH function
|
||||||
|
instead. \(BMH matchers are faster but need much more space.)"
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
;; see <http://www-igm.univ-mlv.fr/~lecroq/string/node18.html> for
|
||||||
|
;; details
|
||||||
|
(unless *use-bmh-matchers*
|
||||||
|
(let ((test (if case-insensitive-p #'char-equal #'char=)))
|
||||||
|
(return-from create-bmh-matcher
|
||||||
|
(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(and (not (minusp start-pos))
|
||||||
|
(search pattern
|
||||||
|
*string*
|
||||||
|
:start2 start-pos
|
||||||
|
:end2 *end-pos*
|
||||||
|
:test test))))))
|
||||||
|
(let* ((m (length pattern))
|
||||||
|
(skip (make-array *regex-char-code-limit*
|
||||||
|
:element-type 'fixnum
|
||||||
|
:initial-element m)))
|
||||||
|
(declare (fixnum m))
|
||||||
|
(loop for k of-type fixnum below m
|
||||||
|
if case-insensitive-p
|
||||||
|
do (setf (aref skip (char-code (char-upcase (schar pattern k)))) (- m k 1)
|
||||||
|
(aref skip (char-code (char-downcase (schar pattern k)))) (- m k 1))
|
||||||
|
else
|
||||||
|
do (setf (aref skip (char-code (schar pattern k))) (- m k 1)))
|
||||||
|
(if case-insensitive-p
|
||||||
|
(bmh-matcher-aux :case-insensitive-p t)
|
||||||
|
(bmh-matcher-aux))))
|
||||||
|
|
||||||
|
(defmacro char-searcher-aux (&key case-insensitive-p)
|
||||||
|
"Auxiliary macro used by CREATE-CHAR-SEARCHER."
|
||||||
|
(let ((char-compare (if case-insensitive-p 'char-equal 'char=)))
|
||||||
|
`(lambda (start-pos)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
(and (not (minusp start-pos))
|
||||||
|
(loop for i of-type fixnum from start-pos below *end-pos*
|
||||||
|
thereis (and (,char-compare (schar *string* i) chr) i))))))
|
||||||
|
|
||||||
|
(defun create-char-searcher (chr case-insensitive-p)
|
||||||
|
"Returns a function which searches the (special) simple-string
|
||||||
|
*STRING* for the first occurence of the character CHR. The search
|
||||||
|
starts at the position START-POS within *STRING* and stops before
|
||||||
|
*END-POS* is reached. Depending on the second argument the search is
|
||||||
|
case-insensitive or not."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(if case-insensitive-p
|
||||||
|
(char-searcher-aux :case-insensitive-p t)
|
||||||
|
(char-searcher-aux)))
|
||||||
|
|
||||||
|
(declaim (inline newline-skipper))
|
||||||
|
(defun newline-skipper (start-pos)
|
||||||
|
"Finds the next occurence of a character in *STRING* which is behind
|
||||||
|
a #\Newline."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (fixnum start-pos))
|
||||||
|
;; we can start with (1- START-POS) without testing for (PLUSP
|
||||||
|
;; START-POS) because we know we'll never call NEWLINE-SKIPPER on
|
||||||
|
;; the first iteration
|
||||||
|
(loop for i of-type fixnum from (1- start-pos) below *end-pos*
|
||||||
|
thereis (and (char= (schar *string* i)
|
||||||
|
#\Newline)
|
||||||
|
(1+ i))))
|
||||||
|
|
||||||
|
(defmacro insert-advance-fn (advance-fn)
|
||||||
|
"Creates the actual closure returned by CREATE-SCANNER-AUX by
|
||||||
|
replacing '(ADVANCE-FN-DEFINITION) with a suitable definition for
|
||||||
|
ADVANCE-FN. This is a utility macro used by CREATE-SCANNER-AUX."
|
||||||
|
(subst
|
||||||
|
advance-fn '(advance-fn-definition)
|
||||||
|
'(lambda (string start end)
|
||||||
|
(block scan
|
||||||
|
;; initialize a couple of special variables used by the
|
||||||
|
;; matchers (see file specials.lisp)
|
||||||
|
(let* ((*string* string)
|
||||||
|
(*start-pos* start)
|
||||||
|
(*end-pos* end)
|
||||||
|
;; we will search forward for END-STRING if this value
|
||||||
|
;; isn't at least as big as POS (see ADVANCE-FN), so it
|
||||||
|
;; is safe to start to the left of *START-POS*; note
|
||||||
|
;; that this value will _never_ be decremented - this
|
||||||
|
;; is crucial to the scanning process
|
||||||
|
(*end-string-pos* (1- *start-pos*))
|
||||||
|
;; the next five will shadow the variables defined by
|
||||||
|
;; DEFPARAMETER; at this point, we don't know if we'll
|
||||||
|
;; actually use them, though
|
||||||
|
(*repeat-counters* *repeat-counters*)
|
||||||
|
(*last-pos-stores* *last-pos-stores*)
|
||||||
|
(*reg-starts* *reg-starts*)
|
||||||
|
(*regs-maybe-start* *regs-maybe-start*)
|
||||||
|
(*reg-ends* *reg-ends*)
|
||||||
|
;; we might be able to optimize the scanning process by
|
||||||
|
;; (virtually) shifting *START-POS* to the right
|
||||||
|
(scan-start-pos *start-pos*)
|
||||||
|
(starts-with-str (if start-string-test
|
||||||
|
(str starts-with)
|
||||||
|
nil))
|
||||||
|
;; we don't need to try further than MAX-END-POS
|
||||||
|
(max-end-pos (- *end-pos* min-len)))
|
||||||
|
(declare (fixnum scan-start-pos)
|
||||||
|
(function match-fn))
|
||||||
|
;; definition of ADVANCE-FN will be inserted here by macrology
|
||||||
|
(labels ((advance-fn-definition))
|
||||||
|
(declare (inline advance-fn))
|
||||||
|
(when (plusp rep-num)
|
||||||
|
;; we have at least one REPETITION which needs to count
|
||||||
|
;; the number of repetitions
|
||||||
|
(setq *repeat-counters* (make-array rep-num
|
||||||
|
:initial-element 0
|
||||||
|
:element-type 'fixnum)))
|
||||||
|
(when (plusp zero-length-num)
|
||||||
|
;; we have at least one REPETITION which needs to watch
|
||||||
|
;; out for zero-length repetitions
|
||||||
|
(setq *last-pos-stores* (make-array zero-length-num
|
||||||
|
:initial-element nil)))
|
||||||
|
(when (plusp reg-num)
|
||||||
|
;; we have registers in our regular expression
|
||||||
|
(setq *reg-starts* (make-array reg-num :initial-element nil)
|
||||||
|
*regs-maybe-start* (make-array reg-num :initial-element nil)
|
||||||
|
*reg-ends* (make-array reg-num :initial-element nil)))
|
||||||
|
(when end-anchored-p
|
||||||
|
;; the regular expression has a constant end string which
|
||||||
|
;; is anchored at the very end of the target string
|
||||||
|
;; (perhaps modulo a #\Newline)
|
||||||
|
(let ((end-test-pos (- *end-pos* (the fixnum end-string-len))))
|
||||||
|
(declare (fixnum end-test-pos)
|
||||||
|
(function end-string-test))
|
||||||
|
(unless (setq *end-string-pos* (funcall end-string-test
|
||||||
|
end-test-pos))
|
||||||
|
(when (and (= 1 (the fixnum end-anchored-p))
|
||||||
|
(> *end-pos* scan-start-pos)
|
||||||
|
(char= #\Newline (schar *string* (1- *end-pos*))))
|
||||||
|
;; if we didn't find an end string candidate from
|
||||||
|
;; END-TEST-POS and if a #\Newline at the end is
|
||||||
|
;; allowed we try it again from one position to the
|
||||||
|
;; left
|
||||||
|
(setq *end-string-pos* (funcall end-string-test
|
||||||
|
(1- end-test-pos))))))
|
||||||
|
(unless (and *end-string-pos*
|
||||||
|
(<= *start-pos* *end-string-pos*))
|
||||||
|
;; no end string candidate found, so give up
|
||||||
|
(return-from scan nil))
|
||||||
|
(when end-string-offset
|
||||||
|
;; if the offset of the constant end string from the
|
||||||
|
;; left of the regular expression is known we can start
|
||||||
|
;; scanning further to the right; this is similar to
|
||||||
|
;; what we might do in ADVANCE-FN
|
||||||
|
(setq scan-start-pos (max scan-start-pos
|
||||||
|
(- (the fixnum *end-string-pos*)
|
||||||
|
(the fixnum end-string-offset))))))
|
||||||
|
(cond
|
||||||
|
(start-anchored-p
|
||||||
|
;; we're anchored at the start of the target string,
|
||||||
|
;; so no need to try again after first failure
|
||||||
|
(when (or (/= *start-pos* scan-start-pos)
|
||||||
|
(< max-end-pos *start-pos*))
|
||||||
|
;; if END-STRING-OFFSET has proven that we don't
|
||||||
|
;; need to bother to scan from *START-POS* or if the
|
||||||
|
;; minimal length of the regular expression is
|
||||||
|
;; longer than the target string we give up
|
||||||
|
(return-from scan nil))
|
||||||
|
(when starts-with-str
|
||||||
|
(locally
|
||||||
|
(declare (fixnum starts-with-len))
|
||||||
|
(cond ((and (case-insensitive-p starts-with)
|
||||||
|
(not (*string*-equal starts-with-str
|
||||||
|
*start-pos*
|
||||||
|
(+ *start-pos*
|
||||||
|
starts-with-len)
|
||||||
|
0 starts-with-len)))
|
||||||
|
;; the regular expression has a
|
||||||
|
;; case-insensitive constant start string
|
||||||
|
;; and we didn't find it
|
||||||
|
(return-from scan nil))
|
||||||
|
((and (not (case-insensitive-p starts-with))
|
||||||
|
(not (*string*= starts-with-str
|
||||||
|
*start-pos*
|
||||||
|
(+ *start-pos* starts-with-len)
|
||||||
|
0 starts-with-len)))
|
||||||
|
;; the regular expression has a
|
||||||
|
;; case-sensitive constant start string
|
||||||
|
;; and we didn't find it
|
||||||
|
(return-from scan nil))
|
||||||
|
(t nil))))
|
||||||
|
(when (and end-string-test
|
||||||
|
(not end-anchored-p))
|
||||||
|
;; the regular expression has a constant end string
|
||||||
|
;; which isn't anchored so we didn't check for it
|
||||||
|
;; already
|
||||||
|
(block end-string-loop
|
||||||
|
;; we temporarily use *END-STRING-POS* as our
|
||||||
|
;; starting position to look for end string
|
||||||
|
;; candidates
|
||||||
|
(setq *end-string-pos* *start-pos*)
|
||||||
|
(loop
|
||||||
|
(unless (setq *end-string-pos*
|
||||||
|
(funcall (the function end-string-test)
|
||||||
|
*end-string-pos*))
|
||||||
|
;; no end string candidate found, so give up
|
||||||
|
(return-from scan nil))
|
||||||
|
(unless end-string-offset
|
||||||
|
;; end string doesn't have an offset so we
|
||||||
|
;; can start scanning now
|
||||||
|
(return-from end-string-loop))
|
||||||
|
(let ((maybe-start-pos (- (the fixnum *end-string-pos*)
|
||||||
|
(the fixnum end-string-offset))))
|
||||||
|
(cond ((= maybe-start-pos *start-pos*)
|
||||||
|
;; offset of end string into regular
|
||||||
|
;; expression matches start anchor -
|
||||||
|
;; fine...
|
||||||
|
(return-from end-string-loop))
|
||||||
|
((and (< maybe-start-pos *start-pos*)
|
||||||
|
(< (+ *end-string-pos* end-string-len) *end-pos*))
|
||||||
|
;; no match but maybe we find another
|
||||||
|
;; one to the right - try again
|
||||||
|
(incf *end-string-pos*))
|
||||||
|
(t
|
||||||
|
;; otherwise give up
|
||||||
|
(return-from scan nil)))))))
|
||||||
|
;; if we got here we scan exactly once
|
||||||
|
(let ((next-pos (funcall match-fn *start-pos*)))
|
||||||
|
(when next-pos
|
||||||
|
(values (if next-pos *start-pos* nil)
|
||||||
|
next-pos
|
||||||
|
*reg-starts*
|
||||||
|
*reg-ends*))))
|
||||||
|
(t
|
||||||
|
(loop for pos = (if starts-with-everything
|
||||||
|
;; don't jump to the next
|
||||||
|
;; #\Newline on the first
|
||||||
|
;; iteration
|
||||||
|
scan-start-pos
|
||||||
|
(advance-fn scan-start-pos))
|
||||||
|
then (advance-fn pos)
|
||||||
|
;; give up if the regular expression can't fit
|
||||||
|
;; into the rest of the target string
|
||||||
|
while (and pos
|
||||||
|
(<= (the fixnum pos) max-end-pos))
|
||||||
|
do (let ((next-pos (funcall match-fn pos)))
|
||||||
|
(when next-pos
|
||||||
|
(return-from scan (values pos
|
||||||
|
next-pos
|
||||||
|
*reg-starts*
|
||||||
|
*reg-ends*)))
|
||||||
|
;; not yet found, increment POS
|
||||||
|
#-cormanlisp (incf (the fixnum pos))
|
||||||
|
#+cormanlisp (incf pos)))))))))
|
||||||
|
:test #'equalp))
|
||||||
|
|
||||||
|
(defun create-scanner-aux (match-fn
|
||||||
|
min-len
|
||||||
|
start-anchored-p
|
||||||
|
starts-with
|
||||||
|
start-string-test
|
||||||
|
end-anchored-p
|
||||||
|
end-string-test
|
||||||
|
end-string-len
|
||||||
|
end-string-offset
|
||||||
|
rep-num
|
||||||
|
zero-length-num
|
||||||
|
reg-num)
|
||||||
|
"Auxiliary function to create and return a scanner \(which is
|
||||||
|
actually a closure). Used by CREATE-SCANNER."
|
||||||
|
(declare #.*standard-optimize-settings*)
|
||||||
|
(declare (fixnum min-len zero-length-num rep-num reg-num))
|
||||||
|
(let ((starts-with-len (if (typep starts-with 'str)
|
||||||
|
(len starts-with)))
|
||||||
|
(starts-with-everything (typep starts-with 'everything)))
|
||||||
|
(cond
|
||||||
|
;; this COND statement dispatches on the different versions we
|
||||||
|
;; have for ADVANCE-FN and creates different closures for each;
|
||||||
|
;; note that you see only the bodies of ADVANCE-FN below - the
|
||||||
|
;; actual scanner is defined in INSERT-ADVANCE-FN above; (we
|
||||||
|
;; could have done this with closures instead of macrology but
|
||||||
|
;; would have consed a lot more)
|
||||||
|
((and start-string-test end-string-test end-string-offset)
|
||||||
|
;; we know that the regular expression has constant start and
|
||||||
|
;; end strings and we know the end string's offset (from the
|
||||||
|
;; left)
|
||||||
|
(insert-advance-fn
|
||||||
|
(advance-fn (pos)
|
||||||
|
(declare (fixnum end-string-offset starts-with-len)
|
||||||
|
(function start-string-test end-string-test))
|
||||||
|
(loop
|
||||||
|
(unless (setq pos (funcall start-string-test pos))
|
||||||
|
;; give up completely if we can't find a start string
|
||||||
|
;; candidate
|
||||||
|
(return-from scan nil))
|
||||||
|
(locally
|
||||||
|
;; from here we know that POS is a FIXNUM
|
||||||
|
(declare (fixnum pos))
|
||||||
|
(when (= pos (- (the fixnum *end-string-pos*) end-string-offset))
|
||||||
|
;; if we already found an end string candidate the
|
||||||
|
;; position of which matches the start string
|
||||||
|
;; candidate we're done
|
||||||
|
(return-from advance-fn pos))
|
||||||
|
(let ((try-pos (+ pos starts-with-len)))
|
||||||
|
;; otherwise try (again) to find an end string
|
||||||
|
;; candidate which starts behind the start string
|
||||||
|
;; candidate
|
||||||
|
(loop
|
||||||
|
(unless (setq *end-string-pos*
|
||||||
|
(funcall end-string-test try-pos))
|
||||||
|
;; no end string candidate found, so give up
|
||||||
|
(return-from scan nil))
|
||||||
|
;; NEW-POS is where we should start scanning
|
||||||
|
;; according to the end string candidate
|
||||||
|
(let ((new-pos (- (the fixnum *end-string-pos*)
|
||||||
|
end-string-offset)))
|
||||||
|
(declare (fixnum new-pos *end-string-pos*))
|
||||||
|
(cond ((= new-pos pos)
|
||||||
|
;; if POS and NEW-POS are equal then the
|
||||||
|
;; two candidates agree so we're fine
|
||||||
|
(return-from advance-fn pos))
|
||||||
|
((> new-pos pos)
|
||||||
|
;; if NEW-POS is further to the right we
|
||||||
|
;; advance POS and try again, i.e. we go
|
||||||
|
;; back to the start of the outer LOOP
|
||||||
|
(setq pos new-pos)
|
||||||
|
;; this means "return from inner LOOP"
|
||||||
|
(return))
|
||||||
|
(t
|
||||||
|
;; otherwise NEW-POS is smaller than POS,
|
||||||
|
;; so we have to redo the inner LOOP to
|
||||||
|
;; find another end string candidate
|
||||||
|
;; further to the right
|
||||||
|
(setq try-pos (1+ *end-string-pos*))))))))))))
|
||||||
|
((and starts-with-everything end-string-test end-string-offset)
|
||||||
|
;; we know that the regular expression starts with ".*" (which
|
||||||
|
;; is not in single-line-mode, see CREATE-SCANNER-AUX) and ends
|
||||||
|
;; with a constant end string and we know the end string's
|
||||||
|
;; offset (from the left)
|
||||||
|
(insert-advance-fn
|
||||||
|
(advance-fn (pos)
|
||||||
|
(declare (fixnum end-string-offset)
|
||||||
|
(function end-string-test))
|
||||||
|
(loop
|
||||||
|
(unless (setq pos (newline-skipper pos))
|
||||||
|
;; if we can't find a #\Newline we give up immediately
|
||||||
|
(return-from scan nil))
|
||||||
|
(locally
|
||||||
|
;; from here we know that POS is a FIXNUM
|
||||||
|
(declare (fixnum pos))
|
||||||
|
(when (= pos (- (the fixnum *end-string-pos*) end-string-offset))
|
||||||
|
;; if we already found an end string candidate the
|
||||||
|
;; position of which matches the place behind the
|
||||||
|
;; #\Newline we're done
|
||||||
|
(return-from advance-fn pos))
|
||||||
|
(let ((try-pos pos))
|
||||||
|
;; otherwise try (again) to find an end string
|
||||||
|
;; candidate which starts behind the #\Newline
|
||||||
|
(loop
|
||||||
|
(unless (setq *end-string-pos*
|
||||||
|
(funcall end-string-test try-pos))
|
||||||
|
;; no end string candidate found, so we give up
|
||||||
|
(return-from scan nil))
|
||||||
|
;; NEW-POS is where we should start scanning
|
||||||
|
;; according to the end string candidate
|
||||||
|
(let ((new-pos (- (the fixnum *end-string-pos*)
|
||||||
|
end-string-offset)))
|
||||||
|
(declare (fixnum new-pos *end-string-pos*))
|
||||||
|
(cond ((= new-pos pos)
|
||||||
|
;; if POS and NEW-POS are equal then the
|
||||||
|
;; the end string candidate agrees with
|
||||||
|
;; the #\Newline so we're fine
|
||||||
|
(return-from advance-fn pos))
|
||||||
|
((> new-pos pos)
|
||||||
|
;; if NEW-POS is further to the right we
|
||||||
|
;; advance POS and try again, i.e. we go
|
||||||
|
;; back to the start of the outer LOOP
|
||||||
|
(setq pos new-pos)
|
||||||
|
;; this means "return from inner LOOP"
|
||||||
|
(return))
|
||||||
|
(t
|
||||||
|
;; otherwise NEW-POS is smaller than POS,
|
||||||
|
;; so we have to redo the inner LOOP to
|
||||||
|
;; find another end string candidate
|
||||||
|
;; further to the right
|
||||||
|
(setq try-pos (1+ *end-string-pos*))))))))))))
|
||||||
|
((and start-string-test end-string-test)
|
||||||
|
;; we know that the regular expression has constant start and
|
||||||
|
;; end strings; similar to the first case but we only need to
|
||||||
|
;; check for the end string, it doesn't provide enough
|
||||||
|
;; information to advance POS
|
||||||
|
(insert-advance-fn
|
||||||
|
(advance-fn (pos)
|
||||||
|
(declare (function start-string-test end-string-test))
|
||||||
|
(unless (setq pos (funcall start-string-test pos))
|
||||||
|
(return-from scan nil))
|
||||||
|
(if (<= (the fixnum pos)
|
||||||
|
(the fixnum *end-string-pos*))
|
||||||
|
(return-from advance-fn pos))
|
||||||
|
(unless (setq *end-string-pos* (funcall end-string-test pos))
|
||||||
|
(return-from scan nil))
|
||||||
|
pos)))
|
||||||
|
((and starts-with-everything end-string-test)
|
||||||
|
;; we know that the regular expression starts with ".*" (which
|
||||||
|
;; is not in single-line-mode, see CREATE-SCANNER-AUX) and ends
|
||||||
|
;; with a constant end string; similar to the second case but we
|
||||||
|
;; only need to check for the end string, it doesn't provide
|
||||||
|
;; enough information to advance POS
|
||||||
|
(insert-advance-fn
|
||||||
|
(advance-fn (pos)
|
||||||
|
(declare (function end-string-test))
|
||||||
|
(unless (setq pos (newline-skipper pos))
|
||||||
|
(return-from scan nil))
|
||||||
|
(if (<= (the fixnum pos)
|
||||||
|
(the fixnum *end-string-pos*))
|
||||||
|
(return-from advance-fn pos))
|
||||||
|
(unless (setq *end-string-pos* (funcall end-string-test pos))
|
||||||
|
(return-from scan nil))
|
||||||
|
pos)))
|
||||||
|
(start-string-test
|
||||||
|
;; just check for constant start string candidate
|
||||||
|
(insert-advance-fn
|
||||||
|
(advance-fn (pos)
|
||||||
|
(declare (function start-string-test))
|
||||||
|
(unless (setq pos (funcall start-string-test pos))
|
||||||
|
(return-from scan nil))
|
||||||
|
pos)))
|
||||||
|
(starts-with-everything
|
||||||
|
;; just advance POS with NEWLINE-SKIPPER
|
||||||
|
(insert-advance-fn
|
||||||
|
(advance-fn (pos)
|
||||||
|
(unless (setq pos (newline-skipper pos))
|
||||||
|
(return-from scan nil))
|
||||||
|
pos)))
|
||||||
|
(end-string-test
|
||||||
|
;; just check for the next end string candidate if POS has
|
||||||
|
;; advanced beyond the last one
|
||||||
|
(insert-advance-fn
|
||||||
|
(advance-fn (pos)
|
||||||
|
(declare (function end-string-test))
|
||||||
|
(if (<= (the fixnum pos)
|
||||||
|
(the fixnum *end-string-pos*))
|
||||||
|
(return-from advance-fn pos))
|
||||||
|
(unless (setq *end-string-pos* (funcall end-string-test pos))
|
||||||
|
(return-from scan nil))
|
||||||
|
pos)))
|
||||||
|
(t
|
||||||
|
;; not enough optimization information about the regular
|
||||||
|
;; expression to optimize so we just return POS
|
||||||
|
(insert-advance-fn
|
||||||
|
(advance-fn (pos)
|
||||||
|
pos))))))
|
||||||
|
|
@ -0,0 +1,172 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-PPCRE; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/specials.lisp,v 1.43 2009/10/28 07:36:15 edi Exp $
|
||||||
|
|
||||||
|
;;; globally declared special variables
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre)
|
||||||
|
|
||||||
|
;;; special variables used to effect declarations
|
||||||
|
|
||||||
|
(defvar *standard-optimize-settings*
|
||||||
|
'(optimize
|
||||||
|
speed
|
||||||
|
(space 0)
|
||||||
|
(debug 1)
|
||||||
|
(compilation-speed 0))
|
||||||
|
"The standard optimize settings used by most declaration expressions.")
|
||||||
|
|
||||||
|
(defvar *special-optimize-settings*
|
||||||
|
'(optimize speed space)
|
||||||
|
"Special optimize settings used only by a few declaration expressions.")
|
||||||
|
|
||||||
|
;;; special variables used by the lexer/parser combo
|
||||||
|
|
||||||
|
(defvar *extended-mode-p* nil
|
||||||
|
"Whether the parser will start in extended mode.")
|
||||||
|
(declaim (boolean *extended-mode-p*))
|
||||||
|
|
||||||
|
;;; special variables used by the SCAN function and the matchers
|
||||||
|
|
||||||
|
(defvar *regex-char-code-limit* char-code-limit
|
||||||
|
"The upper exclusive bound on the char-codes of characters which can
|
||||||
|
occur in character classes. Change this value BEFORE creating
|
||||||
|
scanners if you don't need the \(full) Unicode support of
|
||||||
|
implementations like AllegroCL, CLISP, LispWorks, or SBCL.")
|
||||||
|
(declaim (fixnum *regex-char-code-limit*))
|
||||||
|
|
||||||
|
(defvar *string* (make-sequence #+:lispworks 'lw:simple-text-string
|
||||||
|
#-:lispworks 'simple-string
|
||||||
|
0)
|
||||||
|
"The string which is currently scanned by SCAN.
|
||||||
|
Will always be coerced to a SIMPLE-STRING.")
|
||||||
|
#+:lispworks
|
||||||
|
(declaim (lw:simple-text-string *string*))
|
||||||
|
#-:lispworks
|
||||||
|
(declaim (simple-string *string*))
|
||||||
|
|
||||||
|
(defvar *start-pos* 0
|
||||||
|
"Where to start scanning within *STRING*.")
|
||||||
|
(declaim (fixnum *start-pos*))
|
||||||
|
|
||||||
|
(defvar *real-start-pos* nil
|
||||||
|
"The real start of *STRING*. This is for repeated scans and is only used internally.")
|
||||||
|
(declaim (type (or null fixnum) *real-start-pos*))
|
||||||
|
|
||||||
|
(defvar *end-pos* 0
|
||||||
|
"Where to stop scanning within *STRING*.")
|
||||||
|
(declaim (fixnum *end-pos*))
|
||||||
|
|
||||||
|
(defvar *reg-starts* (make-array 0)
|
||||||
|
"An array which holds the start positions
|
||||||
|
of the current register candidates.")
|
||||||
|
(declaim (simple-vector *reg-starts*))
|
||||||
|
|
||||||
|
(defvar *regs-maybe-start* (make-array 0)
|
||||||
|
"An array which holds the next start positions
|
||||||
|
of the current register candidates.")
|
||||||
|
(declaim (simple-vector *regs-maybe-start*))
|
||||||
|
|
||||||
|
(defvar *reg-ends* (make-array 0)
|
||||||
|
"An array which holds the end positions
|
||||||
|
of the current register candidates.")
|
||||||
|
(declaim (simple-vector *reg-ends*))
|
||||||
|
|
||||||
|
(defvar *end-string-pos* nil
|
||||||
|
"Start of the next possible end-string candidate.")
|
||||||
|
|
||||||
|
(defvar *rep-num* 0
|
||||||
|
"Counts the number of \"complicated\" repetitions while the matchers
|
||||||
|
are built.")
|
||||||
|
(declaim (fixnum *rep-num*))
|
||||||
|
|
||||||
|
(defvar *zero-length-num* 0
|
||||||
|
"Counts the number of repetitions the inner regexes of which may
|
||||||
|
have zero-length while the matchers are built.")
|
||||||
|
(declaim (fixnum *zero-length-num*))
|
||||||
|
|
||||||
|
(defvar *repeat-counters* (make-array 0
|
||||||
|
:initial-element 0
|
||||||
|
:element-type 'fixnum)
|
||||||
|
"An array to keep track of how often
|
||||||
|
repetitive patterns have been tested already.")
|
||||||
|
(declaim (type (array fixnum (*)) *repeat-counters*))
|
||||||
|
|
||||||
|
(defvar *last-pos-stores* (make-array 0)
|
||||||
|
"An array to keep track of the last positions
|
||||||
|
where we saw repetitive patterns.
|
||||||
|
Only used for patterns which might have zero length.")
|
||||||
|
(declaim (simple-vector *last-pos-stores*))
|
||||||
|
|
||||||
|
(defvar *use-bmh-matchers* nil
|
||||||
|
"Whether the scanners created by CREATE-SCANNER should use the \(fast
|
||||||
|
but large) Boyer-Moore-Horspool matchers.")
|
||||||
|
|
||||||
|
(defvar *optimize-char-classes* nil
|
||||||
|
"Whether character classes should be compiled into look-ups into
|
||||||
|
O\(1) data structures. This is usually fast but will be costly in
|
||||||
|
terms of scanner creation time and might be costly in terms of size if
|
||||||
|
*REGEX-CHAR-CODE-LIMIT* is high. This value will be used as the :KIND
|
||||||
|
keyword argument to CREATE-OPTIMIZED-TEST-FUNCTION - see there for the
|
||||||
|
possible non-NIL values.")
|
||||||
|
|
||||||
|
(defvar *property-resolver* nil
|
||||||
|
"Should be NIL or a designator for a function which accepts strings
|
||||||
|
and returns unary character test functions or NIL. This 'resolver' is
|
||||||
|
intended to handle `character properties' like \\p{IsAlpha}. If
|
||||||
|
*PROPERTY-RESOLVER* is NIL, then the parser will simply treat \\p and
|
||||||
|
\\P as #\\p and #\\P as in older versions of CL-PPCRE.")
|
||||||
|
|
||||||
|
(defvar *allow-quoting* nil
|
||||||
|
"Whether the parser should support Perl's \\Q and \\E.")
|
||||||
|
|
||||||
|
(defvar *allow-named-registers* nil
|
||||||
|
"Whether the parser should support AllegroCL's named registers
|
||||||
|
\(?<name>\"<regex>\") and back-reference \\k<name> syntax.")
|
||||||
|
|
||||||
|
(pushnew :cl-ppcre *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
|
||||||
|
|
||||||
|
(defvar *hyperdoc-base-uri* "http://weitz.de/cl-ppcre/")
|
||||||
|
|
||||||
|
(let ((exported-symbols-alist
|
||||||
|
(loop for symbol being the external-symbols of :cl-ppcre
|
||||||
|
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,37 @@
|
||||||
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
|
||||||
|
;;; $Header: /usr/local/cvsrep/cl-ppcre/test/packages.lisp,v 1.4 2009/09/17 19:17:36 edi Exp $
|
||||||
|
|
||||||
|
;;; Copyright (c) 2002-2009, 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-ppcre-test
|
||||||
|
#+genera (:shadowing-import-from :common-lisp :lambda)
|
||||||
|
(:use #-:genera :cl #+:genera :future-common-lisp :cl-ppcre)
|
||||||
|
(:import-from :cl-ppcre :*standard-optimize-settings*
|
||||||
|
:string-list-to-simple-string)
|
||||||
|
(:export :run-all-tests :unicode-test))
|
||||||
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