Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

first commit

  • Loading branch information...
commit e9950d99cd34ed17959ed09723255e4ae1628699 0 parents
Kanen Flowers authored
141 csv.lsp
@@ -0,0 +1,141 @@
+;; @module CSV
+;; @author Jeff Ober <jeffober@gmail.com>
+;; @version 1.1
+;; @location http://static.artfulcode.net/newlisp/csv.lsp
+;; @package http://static.artfulcode.net/newlisp/csv.qwerty
+;; @description Functions for parsing CSV files (updated for newlisp 10)
+;; <h4>Version history</h4>
+;; <b>1.1</b>
+;; &bull; fixed incompatibilities with newlisp 10
+;;
+;; <b>1.0</b>
+;; &bull; initial release
+
+(context 'CSV)
+
+(setq *quote-char* "\"")
+(setq *delimiter* ",")
+
+(define (regex-token-quoted-string delimiter quote-char)
+ (format "^(%s((?:[^%s]|%s%s)+?)%s)(%s|$)"
+ quote-char
+ quote-char
+ quote-char
+ quote-char
+ quote-char
+ delimiter))
+
+(define (regex-token-atom delimiter quote-char)
+ (format "^([^%s%s]+?)(?:%s|$)"
+ quote-char
+ delimiter
+ delimiter))
+
+(define (regex-token-empty delimiter)
+ (format "^%s(?:%s|$)"
+ delimiter
+ delimiter))
+
+;; @syntax (CSV:make-row-parser <str-delimiter> <str-quote-char>)
+;; @param <str-delimiter> column delimiter
+;; @param <str-quote-char> character denoting quoted strings
+;; <p>Returns a lambda that is able to parse a single row of CSV text.
+;; The created function returns a list of column values.</p>
+;; @example
+;; (setq parser (CSV:make-row-parser "," "\""))
+;; => parser function
+;;
+;; (parser "foo,bar,baz,bat")
+;; => ("foo" "bar" "baz" "bat")
+;;
+;; (setq parser (CSV:make-row-parser "|" "\""))
+;; => parser function
+;;
+;; (parser "foo|bar|baz|bat")
+;; => ("foo" "bar" "baz" "bat")
+
+(setq re-chars "|[]{}()<>?\^$*+!:.")
+
+(define (make-row-parser delimiter quote-char)
+ (if (find delimiter re-chars) (setq delimiter (string "\\" delimiter)))
+ (if (find quote-char re-chars) (setq quote-char (string "\\" quote-char)))
+ (letex ((re1 (regex-comp (regex-token-quoted-string delimiter quote-char)))
+ (re2 (regex-comp (regex-token-atom delimiter quote-char)))
+ (re3 (regex-comp (regex-token-empty delimiter))))
+ (lambda (line)
+ (let ((re-1 re1) (re-2 re2) (re-3 re3))
+ (let ((parser (lambda (ln , m)
+ (cond
+ ((set 'm (regex re-1 ln 0x10000))
+ (cons $2 (parser ((+ (m 1) (m 2)) ln))))
+ ((set 'm (regex re-2 ln 0x10000))
+ (cons $1 (parser ((+ (m 1) (m 2)) ln))))
+ ((set 'm (regex re-3 ln 0x10000))
+ (cons {} (parser (1 ln))))
+ (true '())))))
+ (parser line))))))
+
+;; @syntax (CSV:parse-string <str-text> [<str-delimiter> [<str-quote-char>]])
+;; @param <str-text> the text to be parsed
+;; @param <str-delimiter> column delimiter
+;; @param <str-quote-char> character denoting quoted strings
+;; <p>Parses a string of text as a CSV file. Returns a list with one element
+;; for each line; each element is a list of column values for each line in the
+;; text.</p>
+
+(setq EOL-re (regex-comp "\n|\r"))
+
+(define (parse-string str (delimiter *delimiter*) (quote-char *quote-char*))
+ "Parses an entire string into a nested list of rows."
+ (map (make-row-parser delimiter quote-char)
+ (parse str EOL-re 0x10000)))
+
+;; @syntax (CSV:parse-file <str-file> [<str-delimiter> [<str-quote-char>]])
+;; @param <str-file> the file to be read and parsed
+;; @param <str-delimiter> column delimiter
+;; @param <str-quote-char> character denoting quoted strings
+;; <p>Parses a CSV text file. Returns a list with one element
+;; for each line; each element is a list of column values for each line in the
+;; text. <parse-file> parses line by line, rather than processing the entire
+;; string at once, and is therefore more efficient than <parse-file>.</p>
+;; <p><b>Note:</b> at least some versions of MS Excel use a single \r for
+;; line endings, rather than a line feed or both. newLISP's read-line will
+;; only treat \n or \r\n as line endings. If all columns are lumped into one
+;; flat list, this may be the culprit. In this case, use <parse-string> with
+;; <read-file> instead as the best alternative.</p>
+
+(define (parse-file path (delimiter *delimiter*) (quote-char *quote-char*))
+ (let ((f (open path "r"))
+ (parser (make-row-parser delimiter quote-char))
+ (rows '())
+ (buff))
+ (while (setq buff (read-line f))
+ (push (parser buff) rows -1))
+ (close f)
+ rows))
+
+;; @syntax (CSV:list->row <list-cols> <str-delimiter> <str-quote-char>)
+;; @param <str-delimiter> column delimiter; defaults to ","
+;; @param <str-quote-char> character denoting quoted strings; defaults to "\""
+;; @param <str-quote-char> character denoting quoted strings
+;; <p>Generates one row of CSV data from the values in <list-cols>. Non-numeric
+;; elements are treated as quoted strings.</p>
+
+(define (list->row lst (delimiter *delimiter*) (quote-char *quote-char*), (buff ""))
+ (dolist (elt lst)
+ (write-buffer buff (if (number? elt) (string elt)
+ (format "%s%s%s" quote-char (string elt) quote-char)))
+ (write-buffer buff ","))
+ buff)
+
+;; @syntax (CSV:list->csv <list-rows> <str-delimiter> <str-quote-char> <str-eol>)
+;; @param <list-rows> list of row sets (each is a list of values)
+;; @param <str-delimiter> column delimiter; defaults to ","
+;; @param <str-quote-char> character denoting quoted strings; defaults to "\""
+;; @param <str-eol> end of line character; defaults to "\n"
+;; <p>Generates CSV string of a list of column value sets.</p>
+
+(define (list->csv lst (delimiter *delimiter*) (quote-char *quote-char*) (eol-str "\n"))
+ (join (map (fn (r) (list->row r delimiter quote-char)) lst) eol-str))
+
+(context MAIN)
1  csv.qwerty
@@ -0,0 +1 @@
+(define-package "csv")
88 element.lsp
@@ -0,0 +1,88 @@
+;; @module Element
+;; @author Jeff Ober <jeffober@gmail.com>
+;; @version 1.0
+;; @location http://static.artfulcode.net/newlisp/element.lsp
+;; @package http://static.artfulcode.net/newlisp/element.qwerty
+;; @description A simple way of generating valid XML content (requires newlisp 10).
+;; Often, XML modules attempt to provide everything but the kitchen sink when
+;; all that you <really> want is to write valid XML simply and quickly. Element
+;; is a purely practical module that lets you write XML fast and efficiently. It
+;; performs no validation and does nothing apart from serialize data to XML. If
+;; you need extra functionality like indentation or serialization of SXML, look
+;; at the XML module.
+;; <h4>Version history</h4>
+;; <b>1.0</b>
+;; &bull; initial release
+;; <h4>Bugs and todos</h4>
+;; &bull; XML declaration function with encoding
+
+(context 'Element)
+
+(constant 'xml-entity-encode-re (regex-comp (string "(" (join (map (fn (i) (format {\x%x} i)) '(34 38 39 60 62)) "|") ")")))
+
+;; @syntax (Element:encode <str>)
+;; @param <str> a string
+;; <p>Encodes characters in a string to be valid for XML.</p>
+(define (encode str)
+ (replace xml-entity-encode-re (string str) (string "&#" (char $1) ";") 0x10000))
+
+(define (serialize-attributes attributes)
+ (cond
+ ((list? attributes) (join (map (fn (pair) (format " %s=\"%s\"" (map encode pair))) attributes) ""))
+ ((string? attributes) (string " " attributes))
+ (true "")))
+
+(define (opening-tag tag attributes)
+ (string "<" tag (serialize-attributes attributes) ">"))
+
+(define (closing-tag tag)
+ (string "</" tag ">"))
+
+(define (empty-tag tag attributes)
+ (string "<" tag (serialize-attributes attributes) " />"))
+
+;; @syntax (Element:Element <str-tag> <attributes> [<str-content> ...])
+;; @param <str-tag> the tag name
+;; @param <attributes> an association list of key/value pairs, a string, or nil
+;; @param <str-content> any number of strings
+;; <p>Builds an element tag with the name <str-tag> and attributes <attributes>
+;; around the content <str-content>, which generally is also built using this
+;; function. If <attributes> is an association list, it is converted to a series
+;; of key="value" pairs. If it is a string, it is inserted as-is. Otherwise, it
+;; is ignored. <str-content> may be strings generated by XmlBuilder:element or
+;; otherwise (in which case it is inserted as text content). Attribute values are
+;; encoded as needed (if an association list); <str-content> must be encoded if
+;; a text value.</p>
+;; @example
+;; (Element "div" '(("class" "content"))
+;; (Element "h2" nil (Element:encode "Welcome"))
+;; (Element "p" {class="message"} (Element:encode "Hello world.")))
+;;
+;; => <div class="content"><h2>Welcome</h2><p class="message">Hello world.</p></div>
+(define (Element:Element tag attributes)
+ (if (empty? (args))
+ (empty-tag tag attributes)
+ (string
+ (opening-tag tag attributes)
+ (join (map (fn (a)
+ (if (list? a)
+ (join (map string a))
+ (string a)))
+ (args)))
+ (closing-tag tag))))
+
+;; @syntax (Element:doc <str-encoding> [<str-content> ...])
+;; @param <str-encoding> encoding for XML declaration
+;; @param <str-content> any number of strings
+;; <p>Adds an XML declaration to a string. If encoding is nil, defaults to UTF-8
+;; when newlisp is compiled with UTF-8 support, ASCII otherwise.</p>
+;; @example
+;; (Element:doc "UTF-8" (Element "root" nil "Hello world."))
+;; =>
+;; <?xml version="1.0" encoding="UTF-8" ?>
+;; <root>Hello world.</root>
+(define (doc encoding)
+ (unless encoding (setq encoding (if utf8 "UTF-8" "ASCII")))
+ (string {<?xml version="1.0" encoding="} encoding {" ?>} "\n" (join (map string (args)))))
+
+(context 'MAIN)
1  element.qwerty
@@ -0,0 +1 @@
+(define-package "element")
66 http-server.lsp
@@ -0,0 +1,66 @@
+;;; TO DO: documentation
+;;; TO DO: pre-forking handlers using sockets or queues
+
+(load "nlmod/http.lsp")
+(load "nlmod/sockets.lsp")
+(load "nlmod/util.lsp")
+
+(context 'HttpServer)
+(constant 'MAX_REQ_SIZE (* 1024 1024 8)) ; 8 megabytes
+(context 'MAIN)
+
+(define (HttpServer:HttpServer (port 80) fn-req fn-wait fn-error (log-fd (device)) max-req , server)
+ (setf server
+ (list (context)
+ (SocketServer port)
+ log-fd
+ (or max-req HttpServer:MAX_REQ_SIZE)
+ fn-req
+ fn-wait
+ fn-error))
+ (:log server "Server starting up on port " port)
+ server)
+
+(define (HttpServer:socket-server inst) (inst 1))
+(define (HttpServer:fd inst) (inst 2))
+(define (HttpServer:max-request-size) (inst 3))
+(define (HttpServer:request-fn inst) (eval (inst 4)))
+(define (HttpServer:wait-fn inst) (eval (inst 5)))
+(define (HttpServer:error-fn inst) (eval (inst 6)))
+(define (HttpServer:client-socket inst) (inst 7)) ; added in :request-handler
+
+(define (HttpServer:log inst)
+ (let ((old-device (device)))
+ (device (:fd inst))
+ (println (string (join (map string (args)))))
+ (device old-device)))
+
+(define (HttpServer:respond inst response mime-type code headers)
+ (setf mime-type (or mime-type "text/html"))
+ (setf code (or code 200))
+ (setf headers (or headers (list)))
+ (:write (:client-socket inst) (Http:format-response response code mime-type headers))
+ (:close (:client-socket inst)))
+
+(define (HttpServer:request-handler inst socket server , buf req)
+ (when socket
+ (push socket inst -1)
+ (setf buf (:read-chunk socket (:max-request-size inst)))
+ (setf req (Http:parse-request buf))
+ ((:request-fn inst) inst (lookup "method" req) (lookup "path" req) (lookup "content" req))))
+
+(define (HttpServer:wait-handler inst)
+ (when (:wait-fn inst)
+ ((:wait-fn inst))))
+
+(define (HttpServer:error-handler inst)
+ (if (:error-fn inst)
+ ((:error-fn inst))
+ (:log inst "Server error: " (args 0))))
+
+(define (HttpServer:run-server inst)
+ (:run-server
+ (:socket-server inst)
+ (partial HttpServer:request-handler inst)
+ (partial HttpServer:wait-handler inst)
+ (partial HttpServer:error-handler inst)))
108 http.lsp
@@ -0,0 +1,108 @@
+;; @module Http
+;; @author Jeff Ober <jeffober@gmail.com>
+;; @version 1.1
+;; @location http://static.artfulcode.net/newlisp/http.lsp
+;; @package http://static.artfulcode.net/newlisp/http.qwerty
+;; @description A bare-bones HTTP 1.0 library (updated for newlisp 10).
+;; Http is an extremely bare-bones HTTP 1.0 library. Not all functionality
+;; is implemented. In particular, the ability to parse an HTTP response is not
+;; yet finished, but the ability to parse requests and send both requests and
+;; responses is finished.
+;; This module has not been rigorously tested. Your mileage may vary. Requires
+;; newlisp 10.
+;; <h4>Version history</h4>
+;; <b>1.1</b>
+;; &bull; updated for newlisp 10
+;; &bull; code clean-up
+;;
+;; <b>1.0</b>
+;; &bull; initial release
+
+(context 'Http)
+
+(constant 'request-init-re (regex-comp {^(GET|POST|HEAD|PUT) (.+?) HTTP/(1.\d)$}))
+(constant 'request-header-re (regex-comp {^(.+?):\s+(.+?)$}))
+(constant 'line-ending-re (regex-comp [text][\r\n]{2,4}[/text]))
+(constant 'response-template "HTTP/1.0 %d OK\r\nConnection: close\r\nContent-Type: %s\r\nDate: %s\r\nContent-Length: %d%s\r\n\r\n%s")
+
+(define (format-header pair)
+ (format "%s: %s" (title-case (string (pair 0))) (string (pair 1))))
+
+;; @syntax (Http:parse-request <str-request>)
+;; @param <str-request> an HTTP request received
+;; <p>Parses an HTTP request and returns an association list.</p>
+;; @example
+;; (parse-request
+;; (format-request "POST"
+;; "/cgi-bin/post_comment.cgi"
+;; '(("Host" "www.somesite.com"))
+;; "name=Some+Person&comment=Hello+world!"))
+;;
+;; => (("method" "POST")
+;; ("path" "/cgi-bin/post_comment.cgi")
+;; ("http-version" "1.0")
+;; ("headers" (("host" "www.somesite.com")
+;; ("content-length" "37") nil))
+;; ("content" ""))
+(define (parse-request req , lines request headers)
+ (when (and (string? req) (not (empty? req)))
+ (setf lines (map trim (parse req line-ending-re 0x10000)))
+ (setf headers '())
+ (setf request
+ (first (find-all request-init-re (first lines)
+ (list (list "method" $1) (list "path" $2) (list "http-version" $3))
+ 0x10000)))
+ (when request
+ (dolist (line (slice lines 1 -1))
+ (push (first (find-all request-header-re line (list (lower-case $1) $2) 0x10000))
+ headers -1))
+ (push (list "headers" headers) request -1)
+ (push (list "content" (slice (last lines) 0)) request -1)
+ request)))
+
+;; @syntax (Http:format-response <str-response> [<int-code> [<str-content-type> [<assoc-headers>]]])
+;; @param <str-response> the text of the HTTP response
+;; @param <int-code> the HTTP response code; default is 200 (success)
+;; @param <str-content-type> MIME type of response; default is "text/html"
+;; @param <assoc-headers> association list of headers to add to response
+;; <p>Formats an HTTP/1.0 response.</p>
+;; @example
+;; (format-response binary-file-content 200 "audio/mp3")
+;; => "HTTP/1.0 200 OK\r\nConnection: close\r\nContent-Type: audio/mp3\r\nDate: Tue, 08 Jul 2008 10:30:09 EDT\r\nContent-Length: 17\r\n\r\n11000101010101..."
+(define (format-response response (code 200) (content-type "text/html") (extra-headers '()))
+ (format response-template
+ code
+ content-type
+ (date (date-value) 0 "%a, %d %b %Y %H:%M:%S %Z")
+ (length response)
+ (if-not (empty? extra-headers)
+ (string "\r\n" (join (map format-header extra-headers) "\r\n"))
+ "")
+ response))
+
+;; @syntax (Http:format-request <str-method> [<str-path> [<assoc-headers> [<str-content>]]])
+;; @param <str-method> request method (GET, POST, HEAD, or PUT)
+;; @param <str-path> request path; default is "/"
+;; @param <assoc-headers> association list of headers to add to request
+;; @param <str-content> for POST and PUT methods, string containing request content
+;; <p>Formats an appropriate HTTP/1.0 request. Note that the "Host" header must be added explicitly if required.</p>
+;; @example
+;; (format-request "POST"
+;; "/cgi-bin/post_comment.cgi"
+;; '(("Host" "www.somesite.com"))
+;; "name=Some+Person&comment=Hello+world!"))
+;; => "HTTP/1.0 200 OK\r\nConnection: close\r\nContent-Type: text/html\r\nDate: Tue, 08 Jul 2008 10:28:03 EDT\r\nContent-Length: 46\r\n\r\n<html><body><h1>Hello world</h2></body></html>"
+(define (format-request method (path "/") (headers '()) content, (buf ""))
+ (if-not (and (string? method) (find (upper-case method) '("GET" "POST" "HEAD" "PUT")))
+ (throw-error "Invalid or unimplemented HTTP method"))
+ (setf method (upper-case method))
+ (write-buffer buf (format "%s %s HTTP/1.0\r\n" method (string path)))
+ (dolist (header headers)
+ (write-buffer buf (format "%s\r\n" (format-header header))))
+ (when content
+ (write-buffer buf (format "Content-Length: %d\r\n\r\n" (length content)))
+ (write-buffer buf content))
+ (write-buffer buf "\r\n\r\n")
+ buf)
+
+(context MAIN)
1  http.qwerty
@@ -0,0 +1 @@
+(define-package "http")
159 install-db.lsp
@@ -0,0 +1,159 @@
+
+(context 'packages)
+
+(set '_acode '(MAIN:repository (MAIN:title "Artful Code") (MAIN:identifier "acode")
+ (MAIN:contact "Jeff Ober <jeffober@gmail.com>")
+ (MAIN:version 1000)
+ (MAIN:module (MAIN:title "csv") (MAIN:description "A simple parser and serialization utility for delimited text.")
+ (MAIN:url "http://static.artfulcode.net/newlisp/csv.lsp")
+ (MAIN:qwerty "http://static.artfulcode.net/newlisp/csv.qwerty")
+ (MAIN:version 1010)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends nil))
+ (MAIN:module (MAIN:title "element") (MAIN:description "A simple way of generating valid XML content.")
+ (MAIN:url "http://static.artfulcode.net/newlisp/element.lsp")
+ (MAIN:qwerty "http://static.artfulcode.net/newlisp/element.qwerty")
+ (MAIN:version 1000)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends nil))
+ (MAIN:module (MAIN:title "http") (MAIN:description "A bare bones HTTP 1.0 parser and serializer.")
+ (MAIN:url "http://static.artfulcode.net/newlisp/http.lsp")
+ (MAIN:qwerty "http://static.artfulcode.net/newlisp/http.qwerty")
+ (MAIN:version 1010)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends nil))
+ (MAIN:module (MAIN:title "json") (MAIN:description "JSON parser and encoder.")
+ (MAIN:url "http://static.artfulcode.net/newlisp/json.lsp")
+ (MAIN:qwerty "http://static.artfulcode.net/newlisp/json.qwerty")
+ (MAIN:version 1020)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends "acode:util"))
+ (MAIN:module (MAIN:title "matching") (MAIN:description "Complex conditionals using match and unify.")
+ (MAIN:url "http://static.artfulcode.net/newlisp/matching.lsp")
+ (MAIN:qwerty "http://static.artfulcode.net/newlisp/matching.qwerty")
+ (MAIN:version 1000)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends nil))
+ (MAIN:module (MAIN:title "memcached") (MAIN:description "Interface to libmemcached (http://tangent.org/552/libmemcached.html).")
+ (MAIN:url "http://static.artfulcode.net/newlisp/memcached.lsp")
+ (MAIN:qwerty "http://static.artfulcode.net/newlisp/memcached.qwerty")
+ (MAIN:version 330)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends nil))
+ (MAIN:module (MAIN:title "mp") (MAIN:description "Classes for multi-processing and synchronization.")
+ (MAIN:url "http://static.artfulcode.net/newlisp/mp.lsp")
+ (MAIN:qwerty "http://static.artfulcode.net/newlisp/mp.qwerty")
+ (MAIN:version 1000)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends "acode:util"))
+ (MAIN:module (MAIN:title "mysql") (MAIN:description "A new MySQL module to replace the distribution standard module.")
+ (MAIN:url "http://static.artfulcode.net/newlisp/mysql.lsp")
+ (MAIN:qwerty "http://static.artfulcode.net/newlisp/mysql.qwerty")
+ (MAIN:version 1020)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends nil))
+ (MAIN:module (MAIN:title "profiler") (MAIN:description "Profiles applications to help identify bottlenecks.")
+ (MAIN:url "http://static.artfulcode.net/newlisp/profiler.lsp")
+ (MAIN:qwerty "http://static.artfulcode.net/newlisp/profiler.qwerty")
+ (MAIN:version 1000)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends nil))
+ (MAIN:module (MAIN:title "qwerty") (MAIN:description "Provides a dependency-managing library loading mechanism.")
+ (MAIN:url "http://static.artfulcode.net/newlisp/qwerty.lsp")
+ (MAIN:version 1000)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends nil))
+ (MAIN:module (MAIN:title "request") (MAIN:description "Request module to replace input functions in the standard CGI module.")
+ (MAIN:url "http://static.artfulcode.net/newlisp/request.lsp")
+ (MAIN:qwerty "http://static.artfulcode.net/newlisp/request.qwerty")
+ (MAIN:version 1010)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends nil))
+ (MAIN:module (MAIN:title "response") (MAIN:description "Response module to replace output functions in the standard CGI module.")
+ (MAIN:url "http://static.artfulcode.net/newlisp/response.lsp")
+ (MAIN:qwerty "http://static.artfulcode.net/newlisp/response.qwerty")
+ (MAIN:version 1021)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends nil))
+ (MAIN:module (MAIN:title "sockets") (MAIN:description "Classes for socket operations.")
+ (MAIN:url "http://static.artfulcode.net/newlisp/sockets.lsp")
+ (MAIN:qwerty "http://static.artfulcode.net/newlisp/sockets.qwerty")
+ (MAIN:version 1000)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends nil))
+ (MAIN:module (MAIN:title "util") (MAIN:description "Various functions that the other Artful Code libraries depend on.")
+ (MAIN:url "http://static.artfulcode.net/newlisp/util.lsp")
+ (MAIN:qwerty "http://static.artfulcode.net/newlisp/util.qwerty")
+ (MAIN:version 2010)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends nil))
+ (MAIN:module (MAIN:title "xml") (MAIN:description "Parsing and serializing of XML data.")
+ (MAIN:url "http://static.artfulcode.net/newlisp/xml.lsp")
+ (MAIN:qwerty "http://static.artfulcode.net/newlisp/xml.qwerty")
+ (MAIN:version 2010)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends "acode:matching"))
+ (MAIN:module (MAIN:title "xmlrpc-server") (MAIN:description "A simple XML-RPC server.")
+ (MAIN:url "http://static.artfulcode.net/newlisp/xmlrpc-server.lsp")
+ (MAIN:qwerty "http://static.artfulcode.net/newlisp/xmlrpc-server.qwerty")
+ (MAIN:version 1010)
+ (MAIN:newlisp-min-version 10000)
+ (MAIN:newlisp-max-version 10001)
+ (MAIN:depends "acode:element" "acode:http" "acode:sockets" "acode:util"))))
+
+
+(context MAIN)
+
+
+(context 'installed)
+
+(set (sym "_acode:csv" MAIN:installed) 1010)
+
+(set (sym "_acode:element" MAIN:installed) 1000)
+
+(set (sym "_acode:http" MAIN:installed) 1010)
+
+(set (sym "_acode:json" MAIN:installed) 1020)
+
+(set (sym "_acode:matching" MAIN:installed) 1000)
+
+(set (sym "_acode:memcached" MAIN:installed) 330)
+
+(set (sym "_acode:mp" MAIN:installed) 1000)
+
+(set (sym "_acode:mysql" MAIN:installed) 1020)
+
+(set (sym "_acode:profiler" MAIN:installed) 1000)
+
+(set (sym "_acode:qwerty" MAIN:installed) 1000)
+
+(set (sym "_acode:request" MAIN:installed) 1010)
+
+(set (sym "_acode:response" MAIN:installed) 1021)
+
+(set (sym "_acode:sockets" MAIN:installed) 1000)
+
+(set (sym "_acode:util" MAIN:installed) 2010)
+
+(set (sym "_acode:xml" MAIN:installed) 2010)
+
+(set (sym "_acode:xmlrpc-server" MAIN:installed) 1010)
+
+
+(context MAIN)
+
176 json.lsp
@@ -0,0 +1,176 @@
+;; @module Json
+;; @author Jeff Ober <jeffober@gmail.com>
+;; @version 2.0
+;; @location http://static.artfulcode.net/newlisp/json.lsp
+;; @package http://static.artfulcode.net/newlisp/json.qwerty
+;; @description JSON parser and encoder; requires util.lsp (updated for newlisp 10)
+;; <p>Library for parsing JSON data and serializing lisp into JSON.</p>
+;; <h4>Version history</h4>
+;; <b>2.0</b>
+;; &bull; completely rewrite of decoder (thanks to Andrew Pennebaker for pointing out the bugs in the original)
+;;
+;; <b>1.2</b>
+;; &bull; fixed incompatibilities with newlisp 10
+;;
+;; <b>1.1</b>
+;; &bull; added simple escape routine to outputted string values
+;;
+;; <b>1.0</b>
+;; &bull; initial release
+
+(context 'Json)
+
+;; @syntax (Json:lisp->json <expr>)
+;; @param <expr> expression to be converted to JSON
+;; <p>Converts expression <expr> to JSON. Association lists and
+;; contexts are converted into objects. Other lists and arrays are
+;; converted into JSON arrays.</p>
+;; @example
+;; (Json:lisp->json '((a 1) (b 2)))
+;; => "{ 'A': 1, 'b': 2 }"
+;; (Json:lisp->json '(1 2 3 4 5))
+;; => "[1, 2, 3, 4, 5]"
+(define (lisp->json lisp)
+ (case (type-of lisp)
+ ("boolean" (if lisp "true" "false"))
+ ("quote" (lisp->json (eval lisp)))
+ ("symbol" (format "'%s'" (name lisp)))
+ ("string" (format "'%s'" (simple-escape lisp)))
+ ("integer" (string lisp))
+ ("float" (string lisp))
+ ("list" (if (assoc? lisp)
+ (format "{ %s }"
+ (join (map (fn (pair)
+ (format "'%s': %s"
+ (if (symbol? (pair 0))
+ (name (pair 0))
+ (string (pair 0)))
+ (lisp->json (pair 1))))
+ lisp)
+ ", "))
+ (string "[" (join (map lisp->json lisp) ", ") "]")))
+ ("array" (string "[" (join (map lisp->json lisp) ", ") "]"))
+ ("context" (let ((values '()))
+ (dotree (s lisp)
+ (push (format "'%s': %s"
+ (name s)
+ (lisp->json (eval s)))
+ values -1))
+ (format "{ %s }" (join values ", "))))
+ (true (throw-error (format "invalid lisp->json type: %s" lisp)))))
+
+(define (simple-escape str)
+ (replace {[\n\r]+} str {\n} 4)
+ (replace {'} str {\'} 4)
+ str)
+
+;; @syntax (Json:json->lisp <str-json>)
+;; @param <str-json> a valid JSON string
+;; <p>Parses a valid JSON string and returns a lisp structure.
+;; Arrays are converted to lists and objects are converted to
+;; assocation lists.</p>
+;; @example
+;; (Json:json->lisp "[1, 2, 3, 4]")
+;; => (1 2 3 4)
+;; (Json:json->lisp "{ 'x': 3, 'y': 4, 'z': [1, 2, 3] }")
+;; => (("x" 3) ("y" 4) ("z" (1 2 3)))
+(define (json->lisp json)
+ (first (lex (tokenize json))))
+
+(define number-re (regex-comp {^([-+\deE.]+)} 1))
+(define identifier-re (regex-comp {([$_a-zA-Z][$_a-zA-Z0-9]*)(.*)} 4))
+
+(define (read-number text , matched n)
+ "Reads in a number in any Javascript-permissible format and attempts to
+ convert it to a newLISP float. If the number's absolute value is greater
+ than 1e308 (defined as +/-INF in newLISP), the number is returned as a
+ string."
+ (setf text (trim text))
+ (when (setf matched (regex number-re text 0x10000))
+ (setf n (pop text 0 (matched 5)))
+ (list (if (> (abs (float n)) 1e308) n (float n)) text)))
+
+(define (read-string text , quot c escaped split-index str)
+ (setf quot (pop text) str "")
+ (catch
+ (until (empty? (setf c (pop text)))
+ (if (and (= c quot) (not escaped))
+ (throw $idx)
+ (write-buffer str c))
+ (setf escaped (and (not $it) (= c {\})))))
+ (list str text))
+
+(define (read-identifier text , matched)
+ (setf text (trim text))
+ (setf matched (regex identifier-re text 0x10000))
+ (list (case (nth 3 matched)
+ ("true" true) ("TRUE" true)
+ ("false" nil) ("FALSE" nil)
+ ("null" nil) ("NULL" nil)
+ (true (nth 3 matched)))
+ (nth 6 matched)))
+
+(define (tokenize text (acc '()) , tok tail n)
+ (setf text (trim text))
+ (cond
+ ((empty? text) acc)
+ ((regex {^\s+} text 4)
+ (tokenize (replace {^\s+} text "" 0) acc))
+ ((regex number-re text 0x10000)
+ (map set '(tok tail) (read-number text))
+ (push tok acc -1)
+ (tokenize tail acc))
+ ((regex {^['"]} text)
+ (map set '(tok tail) (read-string text))
+ (push tok acc -1)
+ (tokenize tail acc))
+ ((regex [text]^[{}\[\]:,][/text] text)
+ (setf tok (pop text))
+ (case tok
+ ("{" (push 'OPEN_BRACE acc -1))
+ ("}" (push 'CLOSE_BRACE acc -1))
+ ("[" (push 'OPEN_BRACKET acc -1))
+ ("]" (push 'CLOSE_BRACKET acc -1))
+ (":" (push 'COLON acc -1))
+ ("," (push 'COMMA acc -1)))
+ (tokenize text acc))
+ (true
+ (map set '(tok tail) (read-identifier text))
+ (push tok acc -1)
+ (tokenize tail acc))))
+
+(define (lex tokens, (tree '()) (loc '(-1)) (depth 0) (mark 0))
+ ;; Note: mark is used to match colon-pairings' depth against the current
+ ;; depth to prevent commas in a paired value (e.g. foo: [...] or foo: {})
+ ;; from popping the stack.
+ (unless (find (first tokens) '(OPEN_BRACKET OPEN_BRACE))
+ (throw-error "A JSON object must be an object or array."))
+ (dolist (tok tokens)
+ (case tok
+ (OPEN_BRACKET
+ (inc depth)
+ (push (list) tree loc)
+ (push -1 loc))
+ (OPEN_BRACE
+ (inc depth)
+ (push (list) tree loc)
+ (push -1 loc))
+ (CLOSE_BRACKET
+ (dec depth)
+ (pop loc))
+ (CLOSE_BRACE
+ (dec depth)
+ (pop loc))
+ (COLON
+ (push (list (pop tree loc)) tree loc)
+ (push -1 loc)
+ (setf mark depth))
+ (COMMA
+ (when (= mark depth)
+ (setf mark nil)
+ (pop loc)))
+ (true
+ (push tok tree loc))))
+ tree)
+
+(context MAIN)
1  json.qwerty
@@ -0,0 +1 @@
+(define-package "json" (depends "util"))
169 matching.lsp
@@ -0,0 +1,169 @@
+;; @module matching
+;; @author Jeff Ober <jeffober@gmail.com>
+;; @version 1.0
+;; @location http://static.artfulcode.net/newlisp/matching.lsp
+;; @package http://static.artfulcode.net/newlisp/matching.qwerty
+;; @description Complex conditionals using match and unify (updated for newlisp 10)
+;; <p>Matching conditionals make possible a very terse style of programming common to the
+;; ML family of languages.</p>
+;; <h4>Version history</h4>
+;; <b>1.0</b>
+;; &bull; updated for newlisp 10
+;; &bull; renamed module to matching
+;; &bull; removed dependency on util.lsp
+;; &bull; made match-bind a global symbol
+;; &bull; fixed error in documentation for match-cond
+;; &bull; fixed error in match-cond that bound arguments incorrectly
+;; &bull; removed match-with and if-match because they were generally confusing and unnecessary
+;; &bull; match-bind no longer binds exact matches (e.g. 'foo and 'foo), only wildcards
+;; &bull; fixed bug in match-case where target was bound incorrectly in some cases
+;;
+;; <b>0.5</b>
+;; &bull; fixed bug in 'with-match' causing $0 to be misinterpreted in certain circumstances
+;;
+;; <b>0.4</b>
+;; &bull; added 'with-match', a simpler operator that is more idiomatic of newLISP
+;;
+;; <b>0.3</b>
+;; &bull; added 'if-match', 'match-with'
+;;
+;; <b>0.2</b>
+;; &bull; altered argument order in 'match-cond'
+;; &bull; added 'match-case'
+;;
+;; <b>0.1</b>
+;; &bull; initial release
+;; &bull; added 'match-bind', 'match-let'
+
+;; @syntax (match-bind <vars> <pattern> <target>)
+;; @param <vars> symbols to bind
+;; @param <pattern> match pattern
+;; @param <target> match target
+;; <p>If '(match <pattern> <target>)' is valid, binds <vars> to
+;; the result of its evaluation.</p>
+;; @example
+;; (match-bind '(a b) '(? ?) '(1 2))
+;; a => 1
+;; b => 2
+(define (match-bind var-list pattern target)
+ (let ((m (match pattern target)))
+ (map set var-list m)))
+
+(global 'match-bind)
+
+;; @syntax (match-let (<vars> <pattern> <target>) <body> ...)
+;; @param <vars> symbols to bind
+;; @param <pattern> match pattern
+;; @param <target> match target
+;; @param <body> series of forms to be evaluated
+;; <p>'match-let' will evaluate body in an environment where
+;; variables <vars> are bound to the destructured values from
+;; <target> according to match pattern <pattern>. Thus, if
+;; the result of '(match <pattern> <target>)' is '(1 2 (3 4))',
+;; <vars> '(a b c)' will be bound as '((a 1) (b 2) (c '(3 4)))'.</p>
+;; <p>Should <pattern> not match <target>, an error is signaled.
+;; Note that <target> is evaluated before <body> is executed.
+;; <target> is evaluated even if the match fails, as it is the
+;; evaluated form against which <pattern> is matched.</p>
+;; @example
+;; (let ((lst '(1 2 3 4)))
+;; (match-let ((a b c) (? ? *) lst)
+;; (+ a b (apply * c))))
+;;
+;; => 15
+(define-macro (match-let)
+ (letex ((var-list (args 0 0))
+ (pattern (args 0 1))
+ (target (args 0 2))
+ (body (cons 'begin (rest (args)))))
+ (if (match 'pattern target)
+ (local var-list
+ (match-bind 'var-list 'pattern target)
+ body)
+ (throw-error "no match possible"))))
+
+(global 'match-let)
+
+;; @syntax (match-case <target> (<case-pattern> <case-vars> <case-expr>) ...)
+;; @param <target> the expression to match against
+;; @param <case-pattern> the pattern to match with <target>
+;; @param <case-vars> the symbols to bind to the result of the match
+;; @param <case-expr> the form to be evaluated should <case-pattern> match successfully
+;; <p>'match-case' tries a series of match cases in sequence and returns the result of
+;; evaluating the first successful match's <case-expr> in a local scope in which symbols
+;; <case-vars> are bound to the result of matching <case-pattern> against <target>.</p>
+;; @example
+;; (let ((x '(1 2 3 4 5)))
+;; (match-case x
+;; ((? ? ?) (a b c) (println "this form is not evaluated since '(? ? ?) does not match x"))
+;; ((? ? *) (a b c) (println "c is bound to " c " in this form"))
+;; ((*) (a) (println "catch-all")))) ; (*) matches all lists, so it is catch-all for x
+;;
+;; => "c is bound to (3 4 5) in this form"
+(define-macro (match-case)
+ (let ((target (args 0)))
+ (catch
+ (dolist (form (rest (args)))
+ (letex ((tgt (eval target)) (pattern (form 0)) (vars (form 1)) (expr (form 2)))
+ (if (match 'pattern 'tgt)
+ (match-let (vars pattern 'tgt)
+ (throw expr))))))))
+
+(global 'match-case)
+
+;; @syntax (match-cond ((<pattern> <vars> <target>) <body-forms>) ...)
+;; @param <pattern> match pattern
+;; @param <vars> symbols to bind
+;; @param <target> match target
+;; @param <body> series of forms to be evaluated
+;; <p>'match-cond' evaluates a series of match/bind combinations until one
+;; of them evaluates non-nil. The result of the successful match will be bound
+;; to the symbols in <vars>, and the associated <body-forms> will be evaluated
+;; with those symbols locally bound. The result of the evaluation is nil if
+;; no forms match or the result of the final <body-form> evaluated.</p>
+;; <p>'match-cond' is more versatile than 'match-case' in that 'match-cond' may
+;; test against multiple targets and evaluates its <body-forms> in an implicit
+;; 'begin' block.</p>
+;; @example
+;; (let ((x '(1 2 3 4 5)))
+;; (match-cond
+;; (((? ? ?) (a b c) x) (println "evaluation never gets here"))
+;; (((? ? *) (a b c) x) (println "c gets bound to " c))
+;; (((*) (a) x) (println "catch-all")))) ; (*) matches all lists, so is catch-all for x
+;;
+;; => "c gets bound to (3 4 5)"
+(define-macro (match-cond)
+ (catch
+ (doargs (form)
+ (letex ((pattern (form 0 0))
+ (vars (form 0 1))
+ (target (form 0 2))
+ (body (cons 'begin (rest form))))
+ (if (match 'pattern target)
+ (match-let (vars pattern target)
+ (throw body)))))))
+
+(global 'match-cond)
+
+;; @syntax (with-match <target> (<match-form-n> <body-n>) ...)
+;; @param <target> target of the match
+;; @param <match-expr-n> match pattern to be tested against <target>
+;; @param <body-n> block to be evaluated if <match-expr-n> matches successfully
+;; <p>Tests each <match-expr-n> in turn against <target>. On the first successful match,
+;; the system variable '$0' is bound to the result of the match and the paired <body-n> is
+;; evaluated. No further match forms are tested after a successful match and the result of
+;; the evaluation of <body-n> is returned. If no match is successful, 'nil' is returned.</p>
+;; @example
+;; (with-match '(1 2 3 (4 5))
+;; ((? ? ? (? ?)) (apply + $0))
+;; ((? *) (println "Never gets here")))
+;; => 15
+(define-macro (with-match)
+ (letex ((target (args 0)) (forms (rest (args))))
+ (catch
+ (dolist (form 'forms)
+ (letex ((match-form (first form)) (body (cons 'begin (rest form))))
+ (let (($0 (match 'match-form target)))
+ (if $0 (throw body))))))))
+
+(global 'with-match)
1  matching.qwerty
@@ -0,0 +1 @@
+(define-package "matching")
188 memcached.lsp
@@ -0,0 +1,188 @@
+;; @module memcached
+;; @author Jeff Ober <jeffober@gmail.com>
+;; @version 0.3
+;; @location http://static.artfulcode.net/newlisp/memcached.lsp
+;; @package http://static.artfulcode.net/newlisp/memcached.qwerty
+;; @description Interface to libmemcached (http://tangent.org/552/libmemcached.html) (updated for newlisp 10)
+;; <p>This module is a work-in-progress. Currently implemented functions work (or at least they
+;; appear to). The full range of functionality is not nearly implemented, but it works well enough
+;; to allocate, connect, get/set keys, and disconnect/deallocate.</p>
+;; <h4>External libraries</h4>
+;; &bull;
+;; @link http://tangent.org/552/libmemcached.html libmemcached<br>
+;; &bull;
+;; @link http://www.danga.com/memcached/download.bml memcached<br>
+;; &bull;
+;; @link http://monkey.org/~provos/libevent/ libevent&nbsp;(required&nbsp;by&nbsp;memcached)
+;;
+;; <h4>Version history</h4>
+;; <b>0.3</b>
+;; &bull; updated for newlisp 10
+;;
+;; <b>0.2</b>
+;; &bull; cleaned up some functions
+;; &bull; added 'get-keys'
+;;
+;; <b>0.1</b>
+;; &bull; development release
+;;
+;; @example
+;; (memcached:init)
+;; (memcached:add-server "localhost" 8080)
+;; (memcached:set-key "foo" "bar" 30)
+;; (memcached:get-key "foo") ; within 30 seconds
+;; => "bar"
+;; (sleep 30000) ; wait 30 seconds
+;; (memcached:get-key "foo") ; after 30+ seconds
+;; => nil
+;; (memcached:disconnect)
+
+(context 'memcached)
+
+;;; note: technique robbed from mysql5.lsp
+
+(setq files '("/usr/local/lib/libmemcached.so" "/usr/local/lib/libmemcached.dylib"))
+
+(setq libmemcached
+ (files (or (find true (map file? files))
+ (begin (println "cannot find libmemcached library")
+ (exit)))))
+
+(import libmemcached "memcached_create")
+(import libmemcached "memcached_free")
+(import libmemcached "memcached_server_add")
+(import libmemcached "memcached_strerror")
+(import libmemcached "memcached_quit")
+(import libmemcached "memcached_set")
+(import libmemcached "memcached_get")
+(import libmemcached "memcached_mget")
+(import libmemcached "memcached_fetch")
+(import libmemcached "memcached_result_create")
+
+(setq MEMCACHED nil)
+(setq MEMCACHED_RETURN nil)
+(setq ERROR nil)
+
+;; @syntax (memcached:init)
+;; <p>Initializes the 'memcached' module.</p>
+(define (init)
+ (if MEMCACHED (memcached_free MEMCACHED))
+ (setq MEMCACHED (memcached_create 0))
+ (if (zero? MEMCACHED) (setq MEMCACHED nil))
+ (not (nil? MEMCACHED)))
+
+;; @syntax (memcached:disconnect)
+;; <p>Disconnects from all servers and deallocates libmemcached structures.</p>
+(define (disconnect)
+ (when MEMCACHED
+ (memcached_quit MEMCACHED)
+ (memcached_free MEMCACHED)
+ true))
+
+;; @syntax (memcached:add-server <str-host> <int-port>)
+;; @param <str-host> the hostname; required
+;; @param <int-port> the host port; required
+;; <p>Adds a server to be used as a source of cached data. Returns true or nil,
+;; depending on whether the server was successfully added or not.</p>
+;; @example
+;; (memcached:add-server "localhost" 8000)
+;; => true
+(define (add-server host port)
+ (when MEMCACHED
+ (setq MEMCACHED_RETURN (memcached_server_add MEMCACHED host port))
+ (= "SUCCESS" (result))))
+
+;; @syntax (memcached:result)
+;; <p>Returns the result or error from the last operation.</p>
+(define (result)
+ (if (and MEMCACHED MEMCACHED_RETURN)
+ (get-string (memcached_strerror MEMCACHED MEMCACHED_RETURN))))
+
+;; @syntax (memcached:set-key <str-key> <expr-value> [<int-expiration>])
+;; @param <str-key> unique key to store <expr-value> under; required
+;; @param <str-expr> value to store under <str-key>; required
+;; @param <int-expiration> seconds until <str-key> will expire; optional
+;; <p>Sets <str-key> to <str-expr> on the memcached server. <str-expr> will be serialized
+;; using 'string'. Keys that already exist are overwritten. Returns true for success,
+;; nil for failure.</p>
+;; @example
+;; (memcached:set-key "foo" "bar" 30) ; sets "foo" to "bar" for 30 seconds
+;; => true
+(define (_set-key key value expiration)
+ (when MEMCACHED
+ (setq key (string key))
+ (setq value (string value))
+ (setq MEMCACHED_RETURN (memcached_set MEMCACHED key (length key)
+ value (length value)
+ expiration nil))
+ (= "SUCCESS" (result))))
+
+(define (set-key key value expiration)
+ (if (_set-key key value expiration)
+ value))
+
+;; @syntax (memcached:get-key <str-key>)
+;; @param <str-key> the key to retrieve; required
+;; <p>Retrieves the value associated with <str-key> from the memcached server. If the
+;; key does not exist or has expired, evaluates to nil. Otherwise, the string value
+;; is returned.</p>
+;; @example
+;; (memcached:set-key "foo" '("bar" "baz" "bat") (* 60 60))
+;; => true
+;;
+;; (memcached:get-key "foo")
+;; => "(\"bar\" \"baz\" \"bat\")"
+;;
+;; (let ((res (memcached:get-key "foo")))
+;; (if res (eval-string (string "'" res)))) ; evaluate quoted
+;; => ("bar" "baz" "bat")
+(define (get-key key , res (value-length 0) (flags 0))
+ (when MEMCACHED
+ (setq res (memcached_get MEMCACHED
+ key (length key)
+ (address value-length)
+ (address flags)
+ (address MEMCACHED_RETURN)))
+ (unless (zero? res) (get-string res))))
+
+(define (_fetch key , klen vlen flags res)
+ (setq klen (address (length key))
+ vlen (address 0)
+ flags (address 0))
+ (setq res (memcached_fetch MEMCACHED key klen vlen flags (address MEMCACHED_RETURN)))
+ (if (= 0 res) nil (get-string res)))
+
+;; @syntax (memcached:get-keys <list-keys>)
+;; @param <list-keys> a list of strings
+;; <p>Fetches an association list of '(key value) pairs from the
+;; server. Invalid or expired values return nil.</p>
+;; @example
+;; (memcached:set-key "foo" "bar" 300)
+;; => "bar"
+;; (memcached:set-key "baz" "bat" 300)
+;; => "bat"
+;; (memcached:set-key "asdf" "qwerty" 300)
+;; => "qwerty"
+;;
+;; (memcached:get-keys '("foo" "baz" "asdf")
+;; => (("foo" "bar") ("baz" "bat") ("asdf" "qwerty"))
+;;
+;; (memcached:get-keys '("foo" "invalid" "expired"))
+;; => (("foo" "bar") ("invalid" nil) ("expired" nil))
+(define (get-keys list-keys , res num-keys s-keys keys len-s-keys lengths)
+ (setq MEMCACHED_RETURN nil)
+ (when MEMCACHED
+ (setq num-keys (length list-keys)
+ s-keys (map string list-keys)
+ keys (pack (dup "lu" num-keys) s-keys)
+ len-s-keys (map length s-keys)
+ lengths (pack (dup "lu" num-keys) len-s-keys)
+ MEMCACHED_RETURN (memcached_mget MEMCACHED keys lengths num-keys))
+ (when (= (result) "SUCCESS")
+ (setq res '())
+ (dolist (key list-keys)
+ (push (list key (_fetch key)) res -1))))
+ res)
+
+(context 'MAIN)
+
1  memcached.qwerty
@@ -0,0 +1 @@
+(define-package "memcached")
621 mp.lsp
@@ -0,0 +1,621 @@
+;; @module MP
+;; @author Jeff Ober <jeffober@gmail.com>
+;; @version 1.1
+;; @location http://static.artfulcode.net/newlisp/mp.lsp
+;; @package http://static.artfulcode.net/newlisp/mp.qwerty
+;; @description Classes for multi-processing and synchronization (requires newlisp 10)
+;; Provides many classes for controlling access to resources as well as
+;; utilities for common multi-processing tasks. Requires newlisp 10 and the
+;; util module.
+;;
+;; <h4>Version history</h4>
+;; <b>1.1</b>
+;; &bull; MP:iter and MP:map both now check spawn returns for errors and re-throw them
+;; &bull; MP:map and MP:iter now block in sleep, rather than sync, which uses *much* less cpu time
+;;
+;; <b>1.0</b>
+;; &bull; initial release (replaces locks module)
+
+;;;=============================================================================
+;;; MP: multi-processing utilities for newlisp.
+;;;=============================================================================
+
+(context 'MP)
+
+;; @syntax (MP:get-pid)
+;; <p>Returns the pid of the current process.</p>
+;; @example
+;; (MP:get-pid) => 16024
+(define (get-pid) (sys-info 6))
+
+;; @syntax (MP:with-lock-held <lock> <expr> [<expr> ...])
+;; @param <lock> an instance of a locking class with an :acquire and :release method
+;; @param <expr> one or more expressions to be evaluated
+;; <p>Evaluates one or more expressions with <lock> acquired. <lock> may be an
+;; instance of any class with an :acquire and :release method. MP:with-lock-held
+;; guarantees that the lock will be released, even if an error is thrown during
+;; evaluation of the body expressions. Errors thrown will be re-thrown after the
+;; lock is released. The value of the expression is the value of the last body
+;; form evaluated.</p>
+;; @example
+;; (setf lock (Lock))
+;; (MP:with-lock-held lock
+;; (do stuff))
+(define-macro (with-lock-held)
+ (letex ((_inst (args 0))
+ (_body (cons begin (rest (args))))
+ (_err (gensym))
+ (_res (gensym)))
+ (local (_err _res)
+ (:acquire _inst)
+ (setf _err (catch _body '_res))
+ (:release _inst)
+ (if-not _err
+ (throw-error _res)
+ _res))))
+
+;; @syntax (MP:wait <fn-condition> <int-start> <int-max> [<int-timeout>])
+;; @param <fn-condition> a predicate used to test state
+;; @param <int-start> the initial sleep time (milliseconds)
+;; @param <int-max> the maximum sleep time (milliseconds)
+;; @param <int-timeout> the maximum number of milliseconds to wait for <fn-condition> to return true
+;; <p>Blocks until <fn-condition> returns true. Wait will poll <fn-condition>
+;; every <int-start> ms, growing every ten polling cycles up to <int-max> ms,
+;; up to an optional <int-timeout> ms. Returns true when the polling loop
+;; returns normally, nil when <int-timeout> (if present) was reached. Note that
+;; <int-timeout> will be approximately observed; it is affected by the current
+;; interval. If <int-start> and <int-max> are equal, no change in the polling
+;; interval will take place.</p>
+;; @example
+;; ; Blocks until 'some-flag is set to true. Polls initially every 50ms,
+;; ; increasing to 500ms. After 5 seconds (5000 ms), returns even if
+;; ; 'some-flag is nil.
+;;
+;; (MP:wait (fn () (true? some-flag)) 50 500 5000)
+(define (wait condition start-interval max-interval timeout , waited result increase current)
+ (setf increase (ceil (/ (- max-interval start-interval) 10)))
+ (setf current start-interval)
+ (setf waited 0)
+ (until (or (and timeout (>= waited timeout)) ; if timeout param present, check for timeout
+ (setf result (condition))) ; gives us our return value
+ (when (zero? (mod $idx 10))
+ (inc current increase))
+ (inc waited (sleep current)))
+ result)
+
+;; @syntax (MP:map <fun> <seq> [<limit>])
+;; @param <fun> a function to apply to each element of <seq>
+;; @param <seq> a list
+;; @param <limit> the max number of processes to start
+;; @param <timeout> the (approximate) max time to wait for the process to complete
+;; <p>Maps <fun> over <seq>, bounding the number of running processes to
+;; <limit>.</p>
+;; @example
+;; (MP:map pow (sequence 0 4) 4)
+;; => (0 1 4 9 16)
+(define (MP:map fun seq limit timeout , result mem (MP:wait-n 1) (max-wait 500) (increment 2))
+ ; Using an array makes symbol access faster
+ (setf mem (make-array (length seq) gensym))
+ (dolist (elt seq)
+ ; Gradually increasing the sync timeout reduces polling overhead
+ ; for long-running calculations.
+ (when limit
+ (until (< (length (sync)) limit)
+ (when (< wait-n max-wait)
+ (setf wait-n (* increment wait-n)))
+ (sleep wait-n)
+ (sync 50)))
+ ; Add a new child process
+ (spawn (mem $idx) (fun elt)))
+ ; Wait for remaining calculations to complete
+ (sync -1)
+ ; Get results and delete symbols used
+ (setf result (MAIN:map eval (array-list mem)))
+ ; Check for errors in results
+ (dolist (res result)
+ (when (and (string? res) (starts-with res "ERR:"))
+ (throw-error (replace {(ERR: user error : )+} res "" 0))))
+ (array-iter delete mem)
+ ; Return result
+ result)
+
+;; @syntax (MP:iter <fun> <seq> [<limit> [<timeout>]])
+;; @param <fun> a function to apply to each element of <seq>
+;; @param <seq> a list
+;; @param <limit> the max number of processes to start
+;; @param <timeout> the (approximate) max time to wait for the process to complete
+;; <p>Iterates over <seq>, applying <fun> to each element. If <limit> is
+;; specified, will not start more than <limit> processes. Returns the value of
+;; the final iteration.</p>
+;; @example
+;; (MP:iter println (sequence 0 4) 4)
+;; 0
+;; 1
+;; 3
+;; 2
+;; 4
+(define (iter fun seq limit , mem check result (MP:wait-n 1) (max-wait 500) (increment 2))
+ ; Using an array makes symbol access faster
+ (setf mem (make-array (length seq) gensym))
+ (dolist (elt seq)
+ ; Gradually increasing the sync timeout reduces polling overhead
+ ; for long-running calculations.
+ (when limit
+ (until (< (length (sync)) limit)
+ (when (< wait-n max-wait)
+ (setf wait-n (* increment wait-n)))
+ (sleep wait-n)
+ (sync 50)))
+ ; Add a new child process
+ (spawn (mem $idx) (fun elt)))
+ ; Wait for remaining calculations to complete
+ (sync -1)
+ ; Check for errors in results
+ (dotimes (i (length seq))
+ (setf check (eval (nth i mem)))
+ (when (and (string? check) (starts-with check "ERR:"))
+ (throw-error (replace {(ERR: user error : )+} check "" 0))))
+ ; Get results and delete symbols used
+ (setf result (eval (last mem)))
+ (array-iter delete mem)
+ result)
+
+(context 'MAIN)
+
+;;;=============================================================================
+;;; Semaphore: a synchronized counter that blocks when attempting to decrement
+;;; below zero. Also known as a counting semaphore. By default, newly created
+;;; Semaphores are initialized with a count of 1.
+;;;=============================================================================
+
+;; @syntax (Semaphore <int-initial>)
+;; @param <int-initial> the initial value of the semaphore
+;; <p>Creates a synchronized counter that cannot drop below zero. Any attempt to
+;; do so will block until the counter has been incremented (released). A basic
+;; semaphore may count as high or low as desired; this is useful for protecting
+;; queues or stacks. By default, Semaphores are initialized with a value of 1.</p>
+;; @example
+;; (setf sem (Semaphore))
+;; (setf queue '())
+;; (dotimes (i 10)
+;; (push i queue)
+;; (:inc sem 1))
+(define (Semaphore:Semaphore (initial-value 1) , sem)
+ (setf sem (semaphore))
+ (semaphore sem initial-value)
+ (list (context) sem))
+
+;; @syntax (:inc <inst> [<int-amount>])
+;; @param <inst> an instance of Semaphore
+;; @param <int-amount> the amount to increment; default is 1
+;; <p>Increments (releases) the Semaphore by <int-amount>.</p>
+(define (Semaphore:inc inst (n 1))
+ (semaphore (inst 1) n))
+
+;; @syntax (:dec <inst> [<int-amount>])
+;; @param <inst> an instance of Semaphore
+;; @param <int-amount> the amount to decrement; default is 1
+;; <p>Decrements (acquires) the Semaphore by <int-amount>.</p>
+(define (Semaphore:dec inst (n 1))
+ (semaphore (inst 1) (- n)))
+
+;; @syntax (:count <inst>)
+;; @param <inst> an instance of Semaphore
+;; <p>Returns the current count of the Semaphore.</p>
+(define (Semaphore:count inst)
+ (semaphore (inst 1)))
+
+;; @syntax (:acquire <inst> [<blocking> [<int-amount>]])
+;; @param <inst> an instance of Semaphore
+;; @param <blocking> if true (default is true) blocks if Semaphore is held
+;; @param <int-amount> the amount by which the Semaphore is to be decremented
+;; <p>Attempts to acquire the Semaphore. If <blocking> is true, :acquire will
+;; block until Semaphore becomes available. If <blocking> is nil, :acquire will
+;; attempt to acquire the Semaphore and return nil immediately if it is
+;; unavailable.</p>
+(define (Semaphore:acquire inst (blocking true) (n 1))
+ (when (or blocking (>= n (:count inst)))
+ (:dec inst n)))
+
+;; @syntax (:release <inst>)
+;; @param <inst> an instance of Semaphore
+;; <p>Releases the Semaphore.</p>
+(setf Semaphore:release Semaphore:inc)
+
+;;;=============================================================================
+;;; Share: a shared page in memory. Only integers, floats, or strings may be
+;;; stored. To store complex objects, use source and pack to first convert the
+;;; object to a string.
+;;;=============================================================================
+
+;; @syntax (Share)
+;; <p>A Share wraps a single page in memory which may be used to store interger,
+;; float, or string values between processes. In order to store compound objects
+;; or lists, use source and/or pack to serialize the object first. Access to the
+;; Share between different processes must be protected with locking
+;; mechanisms.</p>
+(define (Share:Share)
+ (list (context) (share)))
+
+;; @syntax (:set <inst> <value>)
+;; @param <inst> an instance of Share
+;; @param <value> the new value for the Share
+;; <p>Sets the Share's value to <value>.</p>
+(define (Share:set inst value)
+ (share (inst 1) value))
+
+;; @syntax (:get <inst>)
+;; @param <inst> an instance of Share
+;; <p>Gets the value of the Share.</p>
+(define (Share:get inst)
+ (share (inst 1)))
+
+;;;=============================================================================
+;;; Synchronized: a Share that has access protected with a semaphore.
+;;;=============================================================================
+
+;; @syntax (Synchronized [<initial-value>])
+;; @param <initial-value> the initial value, if any
+;; <p>Synchronized wraps a Share and protects access to it with a Semaphore.</p>
+(define (Synchronized:Synchronized <initial-value>)
+ (setf mem (Share))
+ (when initial-value
+ (:set mem initial-value))
+ (list (context) mem (Semaphore 1)))
+
+;; @syntax (:get <inst>)
+;; @param <inst> an instance of Synchronized
+;; <p>Gets the current value of the Synchronized instance. Will block if another
+;; process is currently getting or setting the value.</p>
+(define (Synchronized:get inst)
+ (MP:with-lock-held (inst 2)
+ (:get (inst 1))))
+
+;; @syntax (:set <inst> <expr>)
+;; @param <inst> an instance of Synchronized
+;; @param <expr> the new value
+;; <p>Sets the value of the Synchronized share. If the new value is an
+;; expression, it will be evaluated with the variable $0 set to the old value
+;; of the share. This is necessary to prevent a deadlock when dealing with
+;; self-referential values.</p>
+;; @example
+;; (setf mem (Synchronized))
+;; (:set mem 10)
+;; => 10
+;; (:set mem (+ 10 $0))
+;; => 20
+(define-macro (Synchronized:set)
+ (letex ((_sync_inst (args 0)) (_sync_expr (args 1)))
+ (MP:with-lock-held (_sync_inst 2)
+ (setf $0 (:get (_sync_inst 1)))
+ (:set (_sync_inst 1) (eval _sync_expr)))))
+
+;;;=============================================================================
+;;; Lock: a binary semaphore. It is an error for a different process than that
+;;; which acquires the lock to release the lock.
+;;;=============================================================================
+
+;; @syntax (Lock)
+;; <p>A Lock is a binary semaphore (or mutual exclusion lock) that may be set to
+;; either 1 (released) or 0 (acquired). It is an error for a process to release
+;; a Lock it has not acquired.</p>
+(define (Lock:Lock)
+ (list (context) (Semaphore) (Synchronized)))
+
+;; @syntax (:acquire <inst> [<blocking>])
+;; @param <inst> an instance of Lock
+;; @param <blocking> whether to block if the Lock is not available (default is true)
+;; <p>Attempts to acquire the Lock, blocking until it becomes available if
+;; <blocking> is true.</p>
+(define (Lock:acquire inst (blocking true))
+ (when (:acquire (inst 1) blocking)
+ (:set (inst 2) (MP:get-pid))
+ true))
+
+;; @syntax (:release <inst>)
+;; @param <inst> an instance of Lock
+;; <p>Releases the Lock.</p>
+(define (Lock:release inst)
+ (if (= (MP:get-pid) (:get (inst 2)))
+ (:release (inst 1))
+ (throw-error "unlocking process does not match owner")))
+
+;;;=============================================================================
+;;; RLock: identical to a Lock except that the locking process may acquire the
+;;; lock multiple times. The number of acquires must be >= the number of
+;;; releases.
+;;;=============================================================================
+
+;; @syntax (RLock)
+;; <p>An RLock is a Lock that may be acquired multiple times by the same
+;; process. This is useful to lock various inter-dependent functions in the same
+;; process with a single lock. Observes the invariant # acquires >= # releases.</p>
+(define (RLock:RLock)
+ (list (context) (Semaphore) (Synchronized) (Synchronized)))
+
+(define (RLock:owner inst)
+ (inst 2))
+
+(define (RLock:counter inst)
+ (inst 3))
+
+(define (RLock:held? inst)
+ (zero? (:count (inst 1))))
+
+(define (RLock:process-is-owner? inst)
+ (= (MP:get-pid) (:get (:owner inst))))
+
+(define (RLock:inc inst)
+ (:set (:counter inst) (+ $0 1)))
+
+(define (RLock:dec inst)
+ (:set (:counter inst) (- $0 1)))
+
+;; @syntax (:acquire <inst> [<blocking>])
+;; @param <inst> an instance of RLock
+;; @param <blocking> whether to block if the RLock is not available (default is true)
+;; <p>Attempts to acquire the RLock, blocking until it becomes available if
+;; <blocking> is true.</p>
+(define (RLock:acquire inst (blocking true))
+ (if (and (:held? inst) (:process-is-owner? inst))
+ (:inc inst)
+ (when (:acquire (inst 1))
+ (:set (:counter inst) 1)
+ (:set (:owner inst) (MP:get-pid)))))
+
+;; @syntax (:release <inst>)
+;; @param <inst> an instance of RLock
+;; <p>Releases the RLock.</p>
+(define (RLock:release inst)
+ (unless (:held? inst)
+ (throw-error "lock is not held"))
+ (unless (:process-is-owner? inst)
+ (throw-error "owner and releasing process do not match"))
+ (:dec inst)
+ (when (zero? (:get (:counter inst)))
+ (:release (inst 1))))
+
+;;;=============================================================================
+;;; Event: a simple mechanism to signal one or more waiting processes that some
+;;; condition has been met.
+;;;=============================================================================
+
+;; @syntax (Event)
+;; <p>An Event is a simple mechanism for synchronization. It allows multiple
+;; processes to block until a controlling process issues a signal to
+;; unblock.</p>
+(define (Event:Event , mem)
+ (list (context) (Synchronized 0)))
+
+;; @syntax (:reset inst)
+;; @param <inst> an instance of Event
+;; <p>Resets this Event. Does <no> checking to see if any processes are
+;; waiting on this event. Those processes will remain locked until this
+;; Event is signaled again.</p>
+(define (Event:reset inst)
+ (:set (inst 1) 0))
+
+;; @syntax (:signaled? inst)
+;; @param <inst> an instance of Event
+;; <p>Returns true if this Event has already been signaled.
+(define (Event:signaled? inst)
+ (= 1 (:get (inst 1))))
+
+;; @syntax (:signal inst)
+;; @param <inst> an instance of Event
+;; <p>Signals <inst> and unblocks any processes waiting on this Event.</p>
+(define (Event:signal inst)
+ (:set (inst 1) 1))
+
+;; @syntax (:wait <inst> [<int-timeout>])
+;; @param <inst> an instance of Event
+;; @param <int-timeout> the maximum number of milliseconds to wait
+;; <p>Blocks until <inst> is signaled or <int-timeout>, if present, expires.
+;; Returns true when exiting normally, nil if wait times out.</p>
+(define (Event:wait inst timeout)
+ (unless (:signaled? inst)
+ (MP:wait (fn () (:signaled? inst)) 50 500 timeout)))
+
+;;;=============================================================================
+;;; Pipe: a one-way communications pipe.
+;;;=============================================================================
+
+;; @syntax (Pipe [<in> <out>])
+;; @param <in> an in-channel of an existing pipe
+;; @param <out> an out-channel of an existing pipe
+;; <p>A Pipe is a one-way communcations channel. If <in> and <out> are supplied,
+;; an existing pipe (such as the result of the pipe function) may be used.</p>
+(define (Pipe:Pipe in out)
+ (unless (and in out)
+ (map set '(in out) (pipe)))
+ (list (context) in out))
+
+(define (Pipe:in inst)
+ (inst 1))
+
+(define (Pipe:out inst)
+ (inst 2))
+
+;; @syntax (:send <inst> <msg>)
+;; @param <inst> an instance of Pipe
+;; @param <msg> the message to send
+;; <p>Sends a message along the Pipe. Returns the number of bytes sent
+;; (including message encoding).</p>
+;; @example
+;; (setf p (Pipe))
+;; (:send p "Hello world.")
+(define (Pipe:send inst msg , expr)
+ (setf expr msg)
+ (setf msg (source 'expr))
+ (write-buffer (:out inst) (string "<msg>" msg "</msg>")))
+
+;; @syntax (:peek <inst>)
+;; @param <inst> an instance of Pipe
+;; <p>Returns the number of bytes ready for reading on Pipe. This does not
+;; correspond directly with the size of the message (extra data is send with
+;; the message).
+(define (Pipe:peek inst)
+ (peek (:in inst)))
+
+;; @syntax (:has-messages? <inst>)
+;; @param <inst> an instance of Pipe
+;; <p>Returns true if there is a message ready to be read from the Pipe.</p>
+(define (Pipe:has-messages? inst)
+ (not (zero? (:peek inst))))
+
+;; @syntax (:receive <inst> [<block>])
+;; @param <inst> an instance of Pipe
+;; @param <block> when true, blocks until a message is available on the Pipe
+;; <p>Returns the next message on the Pipe. By default, blocks until the next
+;; message is available.</p>
+(define (Pipe:receive inst (block true) , msg buf has-messages expr)
+ (setf has-messages (:has-messages? inst))
+ (when (or has-messages ; there is a message waiting
+ (and block (not has-messages))) ; no messages but we will wait
+ (setf msg "")
+ (until (ends-with msg "</msg>")
+ (read-buffer (:in inst) buf 4096 "</msg>")
+ (write-buffer msg buf))
+ (setf msg (slice msg 5 (- (length msg) 5 6)))
+
+ ; eval msg in 'MAIN to work-around source/eval-string bug with FOOP contexts
+ (context 'MAIN)
+ (eval-string msg)
+ (context 'Pipe)
+
+ expr))
+
+;; @syntax (:close <inst>)
+;; @param <inst> an instance of Pipe
+;; <p>Closes the read and write handles for this Pipe.</p>
+(define (Pipe:close inst)
+ (close (inst 1))
+ (close (inst 2)))
+
+;;;=============================================================================
+;;; Channel: a two-way communcations channel using Pipes.
+;;;=============================================================================
+
+;; @syntax (Channel)
+;; <p>Creates a two-way communcations channel using Pipes. Channels have two
+;; Pipes, a parent and a child, each of which may be given to separate processes
+;; to communicate back and forth using the standard Pipe syntax.</p>
+;; @example
+;; (setf ch (Channel))
+;; (map set '(parent child) (:pipes ch))
+;;
+;; ; in parent, send a message
+;; (:send parent "Hello child.")
+;;
+;; ; fork child, receive the message, and send a response
+;; (fork
+;; (begin
+;; (println "Child received: " (:receive child))
+;; (:send child "Hello yourself!")))
+;;
+;; ; in the parent process, block until a response becomes available
+;; (setf resp (:receive parent))
+;; (println "Parent received: " resp)
+(define (Channel:Channel , parent child)
+ (setf parent (pipe))
+ (setf child (pipe))
+ (list (context) (Pipe (parent 0) (child 1)) (Pipe (child 0) (parent 1))))
+
+;; @syntax (:pipes <inst>)
+;; @param <inst> an instance of Channel
+;; <p>Returns a list of the parent and child pipes. Equivalent to
+;; (list (:parent inst) (:child inst)).</p>
+(define (Channel:pipes inst)
+ (list (:parent inst) (:child inst)))
+
+;; @syntax (:parent <inst>)
+;; @param <inst> an instance of Channel
+;; <p>Returns the parent Pipe.</p>
+(define (Channel:parent inst)
+ (inst 1))
+
+;; @syntax (:child <inst>)
+;; @param <inst> an instance of Channel
+;; <p>Returns the child Pipe.</p>
+(define (Channel:child inst)
+ (inst 2))
+
+;;;=============================================================================
+;;; Queue: a synchronized FIFO queue. Objects may be of any size (share is not
+;;; used).
+;;;=============================================================================
+
+;; @syntax (Queue [<size>])
+;; @param <size> the maximum size for the queue (no max if nil)
+;; <p>A Queue is a synchronized first in, first out list of items that is safe
+;; for use in multiple processes. Object size is not restricted as when using
+;; a shared page of memory. A Queue must be closed when no longer needed using
+;; the :close method.</p>
+(define (Queue:Queue size)
+ (list (context) (Pipe) (Semaphore) (when size (Semaphore size))))
+
+(define (Queue:comm inst)
+ (inst 1))
+
+(define (Queue:lock inst)
+ (inst 2))
+
+(define (Queue:counter inst)
+ (inst 3))
+
+;; @syntax (:count <inst>)
+;; @param <inst> an instance of Queue
+;; <p>Returns the number of items currently in the queue.</p>
+(define (Queue:count inst)
+ (:count (:counter inst)))
+
+(define (Queue:inc inst)
+ "Records an increase in the size of the queue."
+ (when (:counter inst)
+ (:dec (:counter inst))))
+
+(define (Queue:dec inst)
+ "Records a decrease in the size of the queue."
+ (when (:counter inst)
+ (:inc (:counter inst))))
+
+;; @syntax (:put <inst> <expr> [<block>])
+;; @param <inst> an instance of Queue
+;; @param <expr> the object to be added
+;; @param <block> when true, blocks until space is available in the queue
+;; <p>Adds <expr> to the Queue, blocking by default. Returns true when the item
+;; was added. If <block> is nil, returns nil when the Queue is full.</p>
+;; @example
+;; (setf q (Queue 4))
+;; (dotimes (i 5)
+;; (if (:put q i nil) (print i)))
+;; => 0123
+(define (Queue:put inst expr (block true))
+ (when (or block (not (zero? (:count inst))))
+ (:inc inst)
+ (:send (:comm inst) expr)
+ true))
+
+;; @syntax (:get <inst> [<block>])
+;; @param <inst> an instance of Queue
+;; @param <block> when true, blocks until an item is available from the queue
+;; <p>Pulls the next item off of the Queue. If <block> is nil, returns nil when
+;; no item is available. Otherwise, blocks until one becomes available.</p>
+(define (Queue:get inst (block true) , msg)
+ (MP:with-lock-held (:lock inst)
+ (setf msg (:receive (:comm inst) block)))
+ (when msg
+ (:dec inst)
+ msg))
+
+;; @syntax (:close <inst>)
+;; @param <inst> an instance of Queue
+;; <p>Closes the Queue and removes its temporary files.</p>
+(define (Queue:close inst)
+ (:close (:comm inst)))
+
+
+
+
+
+
1  mp.qwerty
@@ -0,0 +1 @@
+(define-package "mp" (depends "util"))
610 mysql.lsp
@@ -0,0 +1,610 @@
+;; @module Mysql
+;; @author Jeff Ober <jeffober@gmail.com>
+;; @version 1.05 beta
+;; @location http://static.artfulcode.net/newlisp/mysql.lsp
+;; @package http://static.artfulcode.net/newlisp/mysql.qwerty
+;; @description A new MySQL module to replace the distribution standard module (requires newlisp 10).
+;; The Mysql module has been written from scratch utilizing some of the more
+;; recent features of newLisp, such as FOOP and reference returns. One of its
+;; major design goals was to simplify use as well as broaden the features of
+;; the standard MySQL module, while at the same time allowing the creation of
+;; new, anonymous instances at run-time.
+;;
+;; The Mysql module differs from the distribution standard module in several
+;; important ways. Most obviously, it uses FOOP wrappers for MySQL types. It
+;; also requires clients to free results instances; in the standard module,
+;; only the base MYSQL instance itself must be freed (using MySQL:close-db).
+;;
+;; The significance of this is that it is much simpler to create multiple
+;; connections (without having to duplicate the entire context at compile
+;; time). Result sets are completely independent of each other, and several may
+;; be maintained in any state at once. This also means that a spawned process
+;; may be given its own Mysql instance to use without having to worry about
+;; other processes' instances interfering. Using the standard module, the
+;; entire context would need to be cloned at compile time and given a static
+;; symbol reference (e.g., (new 'MySQL 'db)) in order to run multiple instances
+;; or connections to a server.
+;;
+;; Moreover, because this module uses unpack and MySQL C API accessor
+;; functions, there is no need for the client to calculate member offsets in
+;; MySQL compound types. So long as newLisp was compiled for the same target as
+;; the libmysqlclient library (both are 32 bit or both are 64 bit), everything
+;; should work out of the box. Additionally, MySQL errors are now checked in
+;; the connect and query functions and re-thrown as interpreter errors. Instead
+;; of checking for nil returns and a using MySQL:error to get the error
+;; message, standard error handling with the catch function may be used.
+;;
+;; This module has been tested with MySQL version 5 and 5.1 and newLisp version
+;; 10.0.1. It requires newLisp 10.0 or later.
+;;
+;; <h3>Changelog</h3>
+;; <b>1.05</b>
+;; &bull; Mysql:query now checks if client mistakenly sent single, non-list, argument for format-args
+;;
+;; <b>1.04</b>
+;; &bull; fixed error in documentation example
+;; &bull; changed Mysql:query to allow lists as format parameters
+;; &bull; backward-incompatible change to Mysql:query parameter list
+;; &bull; added Mysql:coerce-type as an independent function
+;;
+;; <b>1.03</b>
+;; &bull; fixed truncation bug when inserting binary data in Mysql:query
+;;
+;; <b>1.02</b>
+;; &bull; field types are now correctly distinguished when MySQL is compiled with 64-bit pointers
+;; &bull; refactored MysqlResult:get-row
+;;
+;; <b>1.01</b>
+;; &bull; fixed invalid function in Mysql:tables, Mysql:fields, and Mysql:databases
+;;
+;; <b>1.0</b>
+;; &bull; initial release
+;;
+;; <h3>Known bugs</h3>
+;; &bull; None (at the moment); <i>please let me know if you find any!</i>
+;;
+;;
+;; @example
+;; &bull; Imperative usage
+;;
+;; (setf db (Mysql)) ; initialize Mysql instance
+;; (:connect db "localhost" "user" "secret" "my_database") ; connect to a server
+;; (setf result (:query db "SELECT * FROM some_table")) ; evaluate a query
+;; (setf rows (:fetch-all result)) ; generate a result
+;; (:close-db db) ; free the database
+;;
+;; &bull; Functional usage with the 'mysql context
+;;
+;; (mysql:on-connect '("localhost" "user" "secret" "my_database")
+;; (lambda (db err)
+;; (if err (throw-error err))
+;; (mysql:row-iter db "SELECT * FROM some_table" nil
+;; (lambda (row)
+;; (println row)))))
+
+;;;============================================================================
+;;; MyCType: a base class providing a basic framework for working with
+;;; MySQL C types and functions
+;;;============================================================================
+
+(setf MyCType:pack-format nil)
+
+(define (MyCType:MyCType addr)
+ (list (context) addr))
+
+(define (MyCType:pointer inst)
+ (inst 1))
+
+(define (MyCType:members inst)
+ (unpack MyCType:pack-format (:pointer inst)))
+
+(define (MyCType:member inst n , unpacked)
+ (nth n (:members inst)))
+
+;;;============================================================================
+;;; Utility functions and macros
+;;;============================================================================
+
+(unless if-not-zero
+ (define-macro (if-not-zero)
+ "If the first argument is not zero, evaluates the rest of the arguments.
+ Useful for checking if the return argument of a C function is non-NULL."
+ (letex ((ptr (eval (args 0))) (body (cons 'begin (rest (args)))))
+ (if-not (zero? ptr)
+ body
+ nil)))
+
+ (constant (global 'if-not-zero)))
+
+;;;============================================================================
+;;; Pre-declare classes and contexts to prevent circular dependencies
+;;;============================================================================
+
+(new 'MyCType 'Mysql)
+(new 'MyCType 'MysqlField)
+(new 'MyCType 'MysqlResult)
+
+(sym "_mysql" '_MYSQL)
+
+;;;============================================================================
+;;; _MYSQL context stores API functions from libmysqlclient
+;;;============================================================================
+
+(context '_MYSQL)
+
+;;; Find the libmysqlclient library on this system
+(setf is-64-bit nil)
+(let ((paths '("/usr/lib/libmysqlclient.so"
+ "/usr/lib64/mysql/libmysqlclient.so"
+ "/usr/local/mysql/lib/libmysqlclient.dylib"
+ "/opt/local/lib/libmysqlclient.dylib"
+ "/sw/lib/libmysqlclient.dylib")))
+ (constant 'libmysqlclient
+ (catch
+ (dolist (path paths)
+ (when (file? path)
+ (if (find "lib64" path) ; some pack formats depend on this
+ (setf is-64-bit true))
+ (throw path))))))
+
+;;; Import library functions
+(import libmysqlclient "mysql_affected_rows")
+(import libmysqlclient "mysql_close")
+(import libmysqlclient "mysql_error")
+(import libmysqlclient "mysql_free_result")
+(import libmysqlclient "mysql_init")
+(import libmysqlclient "mysql_insert_id")
+(import libmysqlclient "mysql_real_connect")
+(import libmysqlclient "mysql_real_query")
+(import libmysqlclient "mysql_store_result")
+(import libmysqlclient "mysql_num_fields")
+(import libmysqlclient "mysql_fetch_field")
+(import libmysqlclient "mysql_num_rows")
+(import libmysqlclient "mysql_fetch_row")
+(import libmysqlclient "mysql_fetch_lengths")
+(import libmysqlclient "mysql_fetch_field_direct")
+(import libmysqlclient "mysql_real_escape_string")
+
+(context 'MAIN)
+
+;;;============================================================================
+;;; Mysql: An independent MySQL connection
+;;;============================================================================
+
+;; @syntax (Mysql)
+;; <p>Returns a new Mysql instance that can safely be used in tandem with other
+;; Mysql instances.</p>
+(define (Mysql:Mysql , ptr)
+ (setf ptr (_MYSQL:mysql_init 0))
+ (if-not-zero ptr
+ (list Mysql ptr)))
+
+;; @syntax (:connect <Mysql-instance> <str-host> <str-user> <str-pass> <str-db> <int-port> <str-socket>)
+;; @param <Mysql-instance> an instance of the Mysql class
+;; @param <str-host> the hostname to connect to
+;; @param <str-user> a MySQL username
+;; @param <str-pass> <str-user>'s password
+;; @param <str-db> the database to initially connect to
+;; @param <int-port> (optional) port number of the MySQL server
+;; @param <int-str> (optional) socket file to connect through
+;; <p>Connects an initialized Mysql instance to a database. Returns <true> if
+;; successful logging in, <nil> if not.</p>
+;; @example
+;; (setf db (Mysql))
+;; (:connect db "localhost" "user" "secret" "my-database")
+;; => true
+
+(define (Mysql:connect inst host user pass db (port 0) (socket 0) , result)
+ "Connects to a MySQL database. Throws an error on failure."
+ (setf result (_MYSQL:mysql_real_connect (:pointer inst) host user pass db port socket 0))
+ (if (zero? result)
+ (throw-error (:error inst))
+ true))
+
+;; @syntax (:close <Mysql-instance>)
+;; @param <Mysql-instance> an instance of the Mysql class
+;; <p>Closes the connection and frees any memory used. This does <not> free the memory
+;; used by results sets from this connection.</p>
+(define (Mysql:close-db inst)
+ (_MYSQL:mysql_close (:pointer inst)))
+
+;; @syntax (:error <Mysql-instance>)
+;; @param <Mysql-instance> an instance of the Mysql class
+;; <p>Returns the last error message as a string or <nil> if there is none.</p>
+(define (Mysql:error inst , ptr str)
+ (setf ptr (_MYSQL:mysql_error (:pointer inst)))
+ ; mysql_error always returns a valid string. If there is no error,
+ ; the string will be empty.
+ (setf str (get-string ptr))
+ (if (= "" str) nil str))
+
+;; @syntax (:coerce-type <Mysql-instance> <object>)
+;; @param <Mysql-instance> an instance of the Mysql class
+;; @param <object> a newLisp object
+;; <p>Coerces <object> into something safe to use in a SQL statement. Lists are
+;; converted into MySQL lists (e.g. '("foo" "bar" "baz") to
+;; ('foo', 'bar', 'baz')) and string values are escaped. This is a helper
+;; function for <Mysql:query>.</p>
+(define (Mysql:coerce-type inst value)
+ (cond
+ ((nil? value) "NULL")
+ ((or (= value "null") (= value "NULL")) value)
+ ((number? value) value)
+ ; Here the string must be packed to be sure that it is not truncated.
+ ((string? value) (format "'%s'" (:escape inst (pack (format "s%d" (length value)) value))))
+ ((list? value) (string "(" (join (map string (map (curry Mysql:coerce-type inst) value)) ", ") ")"))
+ (true (format "'%s'" (:escape inst (string value))))))
+
+;; @syntax (:query <Mysql-instance> <str-statement> [<lst-format-args>])
+;; @param <Mysql-instance> an instance of the Mysql class
+;; @param <str-statement> a SQL statement to execute
+;; @param <lst-format-args> format arguments to the SQL statement
+;; <p>Executes <str-statement>. Throws an error if the statement fails with the
+;; reason. If the statement returns results, a <MysqlResult> class instance is
+;; returned. Otherwise, returns the number of affected rows.</p>
+;; <p>If <lst-format-args> is specified, all parameters are escaped (as
+;; necessary) to generate safe, valid SQL. No quoting of values is required in
+;; the format string; quotes are inserted as needed. To generate a
+;; NULL in the SQL statement, pass <nil> or the string "NULL".</p>
+;; @example
+;; (:query db "SELECT name, employee_id FROM employees")
+;; => (MysqlResult 1069216)
+;;
+;; (:query db "DELETE FROM employees WHERE fired = 1")
+;; => 14
+;;
+;; (:query db '("SELECT id FROM employees WHERE name = %s" '("Johnson, John")))
+;; ; SQL generated: SELECT id FROM employees WHERE name = 'Johnson, John'
+;; => (MysqlResult 1069216)
+
+(define (Mysql:query inst sql format-args , res ptr err params)
+ (unless (or (null? format-args) (list? format-args))
+ (throw-error "Format args must be passed to Mysql:query as a list!"))
+
+ (when (list? format-args)
+ (setf format-args (map (fn (v) (:coerce-type inst v)) format-args))
+ (setf sql (format sql format-args)))
+
+ (setf res (_MYSQL:mysql_real_query (:pointer inst) sql (+ 1 (length sql))))
+ (if (zero? res)
+ (begin
+ ; Always attempt to store result firt. This does not degrade performance
+ ; for non-result-returning queries (according to the MySQL C API docs).
+ (setf ptr (_MYSQL:mysql_store_result (:pointer inst)))
+ ; If mysql_store_result returns a null pointer, it may be an error or
+ ; just mean that a query has no results (e.g. INSERT, DELETE, UPDATE).
+ ; Error status requires a combination of a null pointer and a result
+ ; from error.
+ (when (and (zero? ptr) (setf err (:error inst)))
+ (throw-error err))
+ ; Otherwise, return an appropriate value. In the case of a non-result-
+ ; returning query, return the number of affected rows. Otherwise, return
+ ; a MysqlResult instance.
+ (if (zero? ptr)
+ (:affected-rows inst)
+ (MysqlResult ptr)))
+ ; mysql_real_query returns non-zero in case of an error.
+ (throw-error (:error inst))))
+
+;; @syntax (:insert-id <Mysql-instance>)
+;; @param <Mysql-instance> an instance of the Mysql class
+;; <p>Returns the id of the last inserted row when the target table contains
+;; an AUTOINCREMENT field.</p>
+(define (Mysql:insert-id inst)
+ (_MYSQL:mysql_insert_id (:pointer inst)))
+
+;; @syntax (:affected-rows <Mysql-instance>)
+;; @param <Mysql-instance> an instance of the Mysql class
+;; <p>Returns the number of rows affected by the most recent query.</p>
+(define (Mysql:affected-rows inst)
+ (_MYSQL:mysql_affected_rows (:pointer inst)))
+
+;; @syntax (:escape <Mysql-instance> <str-value>)
+;; @param <Mysql-instance> an instance of the Mysql class
+;; @param <str-value> the string to escape
+;; <p>Escapes a string to assure safety for use in a SQL statement.</p>
+(define (Mysql:escape inst str , res)
+ (setf res (dup " " (+ 1 (* 2 (length str)))))
+ (_MYSQL:mysql_real_escape_string (:pointer inst) res str (length str))
+ res)
+
+;; @syntax (:databases <Mysql-instance>)
+;; @param <Mysql-instance> an instance of the Mysql class
+;; <p>Returns a list of the databases on this server.</p>
+(define (Mysql:databases inst , res)
+ (setf res (:query inst "SHOW DATABASES"))
+ (map first (:fetch-rows res nil)))
+
+;; @syntax (:tables <Mysql-instance> <str-database>)
+;; @param <Mysql-instance> an instance of the Mysql class
+;; @param <str-database> (optional) the database to query for tables
+;; <p>Returns a list of tables available on this server. If <str-database> is
+;; provided, the list of tables will be limited to that database.
+(define (Mysql:tables inst db , sql res)
+ (setf sql (if db (format "SHOW TABLES FROM `%s`" db) "SHOW TABLES"))
+ (setf res (:query inst sql))
+ (map first (:fetch-all res nil)))
+
+;; @syntax (:fields <Mysql-instance> <str-table>)
+;; @param <Mysql-instance> an instance of the Mysql class
+;; @param <str-table> the table to display
+;; <p>Returns metadata about the fields in <str-table>. The data is the result
+;; of a 'SHOW FIELDS' query.</p>
+(define (Mysql:fields inst table)
+ (setf res (:query inst (format "SHOW FIELDS FROM `%s`" table)))
+ (:fetch-rows res))
+
+;;;============================================================================
+;;; MysqlResult: The result of a MySQL query
+;;;============================================================================
+
+;; @syntax (MysqlResult <int-pointer>)
+;; @param <int-pointer> a pointer to a MYSQL_RES struct
+;; <p>Objects of this class are returned by Mysql:query as a result of queries
+;; that generate result sets. This class is not generally instantiated directly
+;; by the client.</p>
+
+;; @syntax (:free <MysqlResult-instance>)
+;; @param <MysqlResult-instance> an instance of the MysqlResult class
+;; <p>Frees the memory used by a result. Must be called for each <MysqlResult>
+;; generated, even if unused.</p>
+(define (MysqlResult:free inst)
+ (_MYSQL:mysql_free_result (:pointer inst)))
+
+;; @syntax (:num-rows <MysqlResult-instance>)
+;; @param <MysqlResult-instance> an instance of the MysqlResult class
+;; <p>Returns the number of results in this result.</p>
+(define (MysqlResult:num-rows inst)
+ (_MYSQL:mysql_num_rows (:pointer inst)))
+
+(define (MysqlResult:num-fields inst)
+ (_MYSQL:mysql_num_fields (:pointer inst)))
+
+(define (MysqlResult:column-lengths inst)
+ (_MYSQL:mysql_fetch_lengths (:pointer inst)))
+
+;; @syntax (:fields <MysqlResult-instance>)
+;; @param <MysqlResult-instance> an instance of the MysqlResult class
+;; <p>Returns a list of MysqlField instances corresponding to the columns in
+;; this result.</p>
+(define (MysqlResult:fields inst , n ptr fields)
+ (setf fields '())
+ (setf n (_MYSQL:mysql_num_fields (:pointer inst)))
+ (until (zero? (setf ptr (_MYSQL:mysql_fetch_field (:pointer inst))))
+ (push (MysqlField ptr) fields -1))
+ fields)
+
+;; @syntax (:fetch-row <MysqlResult-instance> <as-assoc>)
+;; @param <MysqlResult-instance> an instance of the MysqlResult class
+;; @param <as-assoc> (optional) whether to return results as a list or association list
+;; <p>Returns one row from this result. If <as-assoc> is true, the results will
+;; be returned as an association list (true by default). If this is the final row
+;; in the result set, the MysqlResult instance is automatically freed.</p>
+(define (MysqlResult:fetch-row inst (as-assoc true) , ptr num-fields cols lengths row)
+ (setf ptr (_MYSQL:mysql_fetch_row (:pointer inst)))
+ (if-not-zero ptr
+ (setf num-fields (:num-fields inst))
+ (setf cols (unpack (dup "lu" num-fields) ptr)) ; pointers to each column's start
+ (setf lengths (unpack (dup "lu" num-fields) (:column-lengths inst))) ; the length of each column
+ ; We must use the lengths because binary fields might contain null characters,
+ ; which will fool get-string, which grabs chars until it hits a null.
+ (setf row
+ (map (lambda (len col i , value field result)
+ (setf field (MysqlField (_MYSQL:mysql_fetch_field_direct (:pointer inst) i)))
+ (setf value (first (unpack (format "s%d" len) col)))
+ (setf value
+ (case (:type field)
+ ("bigint" (int value))
+ ("bit" (int value 2)) ; untested
+ ("date " (apply date-value (map int (parse value "-"))))
+ ("datetime" (apply date-value (map int (parse value "[-: ]" 0))))
+ ("decimal" (float value))
+ ("double" (float value))
+ ("float" (float value))
+ ("integer" (int value))
+ ("mediumint" (int value))
+ ("null" nil)
+ ("smallint" (int value))
+ ("time" (map int (parse value ":"))) ; does not map to newlisp data type
+ ("timestamp" (apply date-value (map int (parse value "[-: ]" 0))))
+ ("tinyint" (int value))
+ ("year" (int value))
+ (true value)))
+ (if as-assoc (list (:name field) value) value))
+ lengths
+ cols
+ (sequence 0 (- (length cols) 1)))))
+ ; Either return the row value or free the result and return nil.
+ (if (zero? ptr)
+ (begin (:free inst) nil)
+ row))
+
+;; @syntax (:fetch-all <MysqlResult-instance> <as-assoc>)
+;; @param <MysqlResult-instance> an instance of the MysqlResult class
+;; @param <as-assoc> (optional) whether to return results as a list or association list
+;; <p>Returns all rows from this result. If <as-assoc> is true, the results
+;; will be returned as an association list (true by default).</p>
+(define (MysqlResult:fetch-all inst (as-assoc true) , rows row)
+ (setf rows '())
+ (setf row (:fetch-row inst as-assoc))
+ (while row
+ (push row rows)
+ (setf row (:fetch-row inst as-assoc)))
+ rows)
+
+;;;============================================================================
+;;; MysqlField: A field in a MySQL result set
+;;;============================================================================
+
+;typedef struct st_mysql_field {
+; char *name; /* Name of column */
+; char *org_name; /* Original column name, if an alias */
+; char *table; /* Table of column if column was a field */
+; char *org_table; /* Org table name, if table was an alias */
+; char *db; /* Database for table */
+; char *catalog; /* Catalog for table */
+; char *def; /* Default value (set by mysql_list_fields) */
+; unsigned long length; /* Width of column (create length) */
+; unsigned long max_length; /* Max width for selected set */
+; unsigned int name_length;
+; unsigned int org_name_length;
+; unsigned int table_length;
+; unsigned int org_table_length;
+; unsigned int db_length;
+; unsigned int catalog_length;
+; unsigned int def_length;
+; unsigned int flags; /* Div flags */
+; unsigned int decimals; /* Number of decimals in field */
+; unsigned int charsetnr; /* Character set */
+; enum enum_field_types type; /* Type of field. See mysql_com.h for types */
+;} MYSQL_FIELD;
+
+;; @syntax (MysqlField <int-pointer>)
+;; @param <int-pointer> a pointer to a MYSQL_FIELD struct
+;; <p>Objects of this class are returned by MysqlResult:fields. It is used
+;; internally in generating result rows. This class is not generally
+;; instantiated directly by the client.</p>
+
+(setf MysqlField:types ; see mysql_com.h for enum details
+ (map list
+ (append (sequence 0 16) (sequence 246 255))
+ '("decimal" "tinyint" "smallint" "integer" "float" "double" "null" "timestamp"
+ "bigint" "mediumint" "date " "time" "datetime" "year" "newdate" "varchar"
+ "bit" "decimal" "enum" "set" "tiny blob" "medium blob" "long blob" "blob"
+ "varchar" "char" "geometry")))
+
+(if _MYSQL:is-64-bit
+ (setf MysqlField:pack-format (append (dup "Lu" 9) (dup "lu" 11))) ; use 64-bit pointers
+ (setf MysqlField:pack-format (append (dup "lu" 20))))
+
+;; @syntax (:name <MysqlField-instance>)
+;; @param <MysqlField-instance> an instance of the MysqlField class
+;; <p>Returns the name of this field (or its alias).</p>
+(define (MysqlField:name inst)
+ (get-string (:member inst 0)))
+
+;; @syntax (:table <MysqlField-instance>)
+;; @param <MysqlField-instance> an instance of the MysqlField class
+;; <p>Returns this field's table (or its alias).</p>
+(define (MysqlField:table inst)
+ (get-string (:member inst 2)))
+
+;; @syntax (:type <MysqlField-instance>)
+;; @param <MysqlField-instance> an instance of the MysqlField class
+;; <p>Returns this field's type.</p>
+(define (MysqlField:type inst)
+ (lookup (:member inst 19) MysqlField:types))
+
+;;;============================================================================
+;;; mysql context contains convenience functions for working with MySQL
+;;; databases
+;;;============================================================================
+
+(context 'mysql)
+
+;; @syntax (mysql:on-connect <list-credentials> <fn-callback>)
+;; @param <list-credentials> a list of parameters to pass to Mysql:connect
+;; @param <fn-callback> a function to call with the database connection
+;; <p>Connects to a MySQL server using <list-credentials> and calls
+;; <fn-callback> using the Mysql instance as the first argument. If an
+;; error occurred attempting connection, the error string is passed as the
+;; second parameter. The minimum contents of <list-credentials> must be
+;; '(<str-host> <str-username> <str-password> <str-database>).</p>
+;; <p>The connection is automatically freed when mysql:on-connect returns.</p>
+;; @example
+;; (mysql:on-connect '("localhost" "user" "secret" "my_database")
+;; (lambda (db err)
+;; (if err
+;; (println "Error! " err)
+;; (println "Success! " db))))
+(define (on-connect credentials func , db err success? result)
+ (setf db (Mysql))
+ (if (catch (eval (append '(:connect db) credentials)) 'err)
+ (setf success? (catch (func db) 'result))
+ (setf success? (catch (func db err) 'result)))
+ (:close-db db)
+ (if success? result (throw-error (replace {(ERR: user error : )+} result "" 0))))
+
+;; @syntax (mysql:row-iter <Mysql-instance> <str-sql> <bool-as-assoc> <fn-callback>)
+;; @param <Mysql-instance> a connect instance of the Mysql class
+;; @param <str-sql> a sql statement
+;; @param <bool-as-assoc> flags whether or not to pass rows as regular or association lists
+;; @param <fn-callback> a function to call for each row returned by the query
+;; <p>Iterates over the results of a query, passing a row at a time to
+;; <fn-callback>. The MysqlResult is automatically freed. The return value
+;; of mysql:row-iter is the result of the last call to <fn-callback>.</p>
+;; <p>Note that each row is called with MysqlResult:fetch-row to avoid building
+;; intermediate lists.</p>
+;; @example
+;; (mysql:on-connect '("localhost" "user" "secret" "my_database")
+;; (lambda (db err)
+;; (if err
+;; (println "Error! " err)
+;; (mysql:row-iter db "SELECT * FROM some_table" true
+;; (lambda (row) (println row))))))
+(define (row-iter db sql as-assoc func , result row)
+ (setf result (:query db sql))
+ (while (setf row (:fetch-row result as-assoc))
+ (func row)))
+
+;; @syntax (mysql:row-map <Mysql-instance> <str-sql> <bool-as-assoc> <fn-callback>)
+;; @param <Mysql-instance> a connect instance of the Mysql class
+;; @param <str-sql> a sql statement
+;; @param <bool-as-assoc> flags whether or not to pass rows as regular or association lists
+;; @param <fn-callback> a function to apply to each row returned by the query
+;; <p>Maps <fn-callback> over each row returned by querying <Mysql-instance>
+;; with <str-sql>. Memory used by the MysqlResult is automatically freed.
+;; Returns a list of the result of applying <fn-callback> to each row.</p>
+;; @example
+;; (mysql:on-connect '("localhost" "user" "secret" "my_database")
+;; (lambda (db err)
+;; (if err
+;; (println "Error! " err)
+;; (mysql:row-iter db "SELECT * FROM some_table" true first))))
+(define (row-map db sql as-assoc func , res result rows)
+ (setf result (:query db sql))
+ (if (catch (:fetch-all result as-assoc) 'rows)
+ (map func rows)))
+
+;; @syntax (mysql:reduce-results <Mysql-instance> <str-sql> <bool-as-assoc> <fn-callback>)
+;; @param <Mysql-instance> a connect instance of the Mysql class
+;; @param <str-sql> a sql statement
+;; @param <bool-as-assoc> flags whether or not to pass rows as regular or association lists
+;; @param <fn-callback> a function to be applied in reducing the results of the query
+;; <p>Reduces the results of the query by applying <fn-callback> successively
+;; to slices of the list of rows from the left. On the first call to
+;; <fn-callback>, the arguments will be a number of rows equal to the number of
+;; parameters that <fn-callback> accepts. On each subsequent call, the first
+;; parameter will be replaced by the result of the previous call. See the
+;; @link http://www.newlisp.org/newlisp_manual.html#apply apply&nbsp;function
+;; for a more detailed description of the mechanics of apply/reduce. The return
+;; value is the result of the final application of <fn-callback>.</p>
+;; @example
+;; (mysql:on-connect '("localhost" "user" "secret" "my_database")
+;; (lambda (db err)
+;; (if err
+;; (println "Error! " err)
+;; (mysql:row-reduce db "SELECT * FROM some_table" true
+;; (lambda (row-1 row-2)
+;; (+ (if (list? row-1) (first row-1) row-1) (first row-2)))))))
+(define (row-reduce db sql as-assoc func , reduce-by rows arg-list)
+ ; Determine the number of rows to reduce by on each call
+ (setf arg-list (map name (first func)))
+ (if (find "," arg-list)
+ (setf reduce-by (length (rest (member "," (reverse arg-list)))))
+ (setf reduce-by (length arg-list)))
+ ; Perform reduction
+ (setf result (:query db sql))
+ (if (catch (:fetch-all result as-assoc) 'rows)
+ (apply func rows reduce-by)))
+
+(context 'MAIN)
+
+
+
+
+
+
+
+
+
1  mysql.qwerty
@@ -0,0 +1 @@
+(define-package "mysql")
190 profiler.lsp
@@ -0,0 +1,190 @@
+;; @module Profiler
+;; @author Jeff Ober <jeffober@gmail.com>
+;; @version 1.0
+;; @location http://static.artfulcode.net/newlisp/profiler.lsp
+;; @package http://static.artfulcode.net/newlisp/profiler.qwerty
+;; @description Profiles applications to help identify bottlenecks (updated for newlisp 10)
+;; <h4>Version history</h4>
+;; <b>1.3</b>
+;; &bull; fixed incompatibilities with newlisp 10
+;;
+;; <b>1.2</b>
+;; &bull; added percentage of total time to report
+;; &bull; added ability to sort report by column
+;;
+;; <b>1.1</b>
+;; &bull; updated report to dynamically calculate column lengths
+;; &bull; updated profile-context to accept multiple contexts
+;;
+;; <b>1.0</b>
+;; &bull; initial release
+;;
+;; @example
+;; (define (fib:fib n)
+;; (if (< n 2) 1
+;; (+ (fib (- n 1)) (fib (- n 2)))))
+;;
+;; (define (fib-memo:fib-memo n)
+;; (or (context 'fib-memo (string n))
+;; (if (< n 2) 1
+;; (context 'fib-memo (string n)
+;; (+ (fib-memo (- n 1)) (fib-memo (- n 2)))))))
+;;
+;; (Profiler:profile-context fib fib-memo)
+;; (dotimes (i 25)
+;; (println "Fib " i ": " (fib i))
+;; (fib-memo i))
+;; (println)
+;; (Profiler:report 'calls)
+;;
+;; =>
+;; Fib 0: 1
+;; Fib 1: 1
+;; Fib 2: 2
+;; Fib 3: 3
+;; Fib 4: 5
+;; Fib 5: 8
+;; Fib 6: 13
+;; Fib 7: 21
+;; Fib 8: 34
+;; Fib 9: 55
+;; Fib 10: 89
+;; Fib 11: 144
+;; Fib 12: 233
+;; Fib 13: 377
+;; Fib 14: 610
+;; Fib 15: 987
+;; Fib 16: 1597
+;; Fib 17: 2584
+;; Fib 18: 4181
+;; Fib 19: 6765
+;; Fib 20: 10946
+;; Fib 21: 17711
+;; Fib 22: 28657
+;; Fib 23: 46368
+;; Fib 24: 75025
+;;
+;; function | calls | total ms | ms/call | % time
+;; -------------------+------------+------------+---------------+-----------