Feeds:
Posts
Comments

Archive for the ‘Scheme’ Category

There are a number of different methods for passing data between pages. These include:

1. Passing the data in a query string.
2. Storing the data in a hidden field and using Javascript to respond to onClick on the links.
3. Storing the data on the server and retrieving it using a session id.

The first option can be very wasteful if we have a large table with many columns. We would have to replicate the data for each column.

The second option seems reasonable but excludes people who disable Javascript so I favour using sessions.

I’m not aware of a PLT scheme library that handles sessions for CGI but it is easy enough to create a very basic example. For our purposes, we will store the sessions in the temporary directory and not have any type of session expiry.

PLT scheme has a nice library called serialize.ss which replaces a lot of the code I discussed earlier. We define a session as a serializable struct which contains the session id, the filename where the data lives and the data itself.

(define-serializable-struct session (id filename data))

The data in a session is simply key value pairs so we provide functions to store and retrieve the data and check if it exists. This implementation obviously assumes that data is a hash table.

(define (session-data-put! session key value)
  (hash-table-put! (session-data session) key value))

(define (session-data-get session key)
  (hash-table-get (session-data session) key (lambda () #f)))

(define (session-data-exists? session key)
  (with-handlers ((exn:fail:contract? (lambda (exn) #f)))
    (hash-table-get (session-data session) key)
    #t))

We also need some way of storing and retrieving sessions on the filesystem. Loading the session checks if one exists for a given session ID. If not, it uses make-temporary-file.

(define *temp-file-prefix* "cgisession-")
(define *temp-file-format-string*
  (string-append *temp-file-prefix* "~a"))

(define (filename->session-id filename)
  (cadr (regexp-match (string-append *temp-file-prefix*
                                     "([-0-9]+)$")
                      (path->string filename))))

(define (load-session session-id)
  (let ((tmp-filename (build-path (find-system-path 'temp-dir)
                                  (string-append *temp-file-prefix*
                                                 session-id))))
    (if (file-exists? tmp-filename)
        (call-with-input-file tmp-filename
          (lambda (port) (deserialize (read port))))
        (let ((filename (make-temporary-file *temp-file-format-string*)))
          (make-session (filename->session-id filename)
                        filename
                        (make-hash-table 'equal))))))

This is less robust than it could be, e.g. if the temporary file exists and does not contain something that we can deserialize then it will fall over. Fixing that is left as an exercise.

Saving the session is trivial.

(define (save-session session)
  (let ((port (open-output-file (session-filename session) 'truncate)))
    (print (serialize session) port)
    (close-output-port port)))

Finally, here is the full code listing including a few tests.

(require (lib "file.ss"))
(require (lib "serialize.ss"))

(define *temp-file-prefix* "cgisession-")
(define *temp-file-format-string*
  (string-append *temp-file-prefix* "~a"))

(define-serializable-struct session (id filename data))

(define (filename->session-id filename)
  (cadr (regexp-match (string-append *temp-file-prefix*
                                     "([-0-9]+)$")
                      (path->string filename))))

(define (load-session session-id)
  (let ((tmp-filename (build-path (find-system-path 'temp-dir)
                                  (string-append *temp-file-prefix*
                                                 session-id))))
    (if (file-exists? tmp-filename)
        (call-with-input-file tmp-filename
          (lambda (port) (deserialize (read port))))
        (let ((filename (make-temporary-file *temp-file-format-string*)))
          (make-session (filename->session-id filename)
                        filename
                        (make-hash-table 'equal))))))

(define (save-session session)
  (let ((port (open-output-file (session-filename session) 'truncate)))
    (print (serialize session) port)
    (close-output-port port)))

(define (session-data-put! session key value)
  (hash-table-put! (session-data session) key value))

(define (session-data-get session key)
  (hash-table-get (session-data session) key (lambda () #f)))

(define (session-data-exists? session key)
  (with-handlers ((exn:fail:contract? (lambda (exn) #f)))
    (hash-table-get (session-data session) key)
    #t))

;;; --- Test code --- ;;;

(define *session-id* "1234")
(define s (load-session *session-id*))
(set! *session-id* (session-id s))

(session-data-put! s 'k 'v)
(session-data-get s 'k)
(session-data-exists? s 'k1)

(save-session s)

Read Full Post »

I know that last time I said we would look at passing data to other pages and data sorting but instead I thought I would make a brief diversion into sqlite. Playing around with table data such as this:

a b c
1 2 3
4 5 6
7 8 9

which is rendered by:

(print-ln (render-table (make-table
                         '("a" "b" "c")
                         '(("1" "2" "3")
                           ("4" "5" "6")
                           ("7" "8" "9")))
                        '()))

is pretty uninspiring. Instead, I can use some financial data that is available from yahoo. Data for the first 50 (or so) NASDAQ stocks is available here.

(require (lib "url.ss" "net"))

(define (print-ln . args)
  (for-each display args)
  (newline))

(define *url-prefix* "http://download.finance.yahoo.com/d/quotes.csv?")
(define *url* (string-append *url-prefix*
                             "s=@%5EIXIC&f=sl1d1t1c1ohgv&e=.csv&h=50"))

(define (display-url url)
  (let ((p (get-pure-port (string->url url))))
    (let loop ((line (read-line p)))
      (unless (eof-object? line)
        (print-ln line)
        (loop (read-line p))))
    (close-input-port p)))

(display-url *url*)

Running this script gives the rather strange error message Missing Format Variable.

(url->string (string->url *url*))

reveals the reason. string->url corrupts the url! It should be this:

http://download.finance.yahoo.com/d/quotes.csv?s=@%5EIXIC&f=sl1d1t1c1ohgv&e=.csv&h=50

But instead it is this (ampersands converted to semi-colons amongst aother things):

http://download.finance.yahoo.com/d/quotes.csv?s=%40%5EIXIC;f=sl1d1t1c1ohgv;e=.csv;h=50

Yahoo rejects the later url with the error message as above.

Absolutely unbe-fricking-lievable.

I can’t imagine the thinking behind making string->url take a perfectly valid URL and breaking it. If you must do this, at least provide a function that doesn’t have this behaviour, say string->url and string->borked-url. This totally unreasonable design decision has damaged my confidence in the PLT scheme standard library. It is possible to work around the stupid default behaviour (although the fix presumably breaks URLs with semi-colons in the query string).

(require (lib "url.ss" "net")
         (lib "uri-codec.ss" "net"))

(current-alist-separator-mode 'amp)

(define (print-ln . args)
  (for-each display args)
  (newline))

(define *url-prefix* "http://download.finance.yahoo.com/d/quotes.csv?")
(define *url* (string-append *url-prefix*
                             "s=@%5EIXIC&f=sl1d1t1c1ohgv&e=.csv&h=50"))

(define (display-url url)
  (let ((p (get-pure-port (string->url url))))
    (let loop ((line (read-line p)))
      (unless (eof-object? line)
        (print-ln line)
        (loop (read-line p))))
    (close-input-port p)))

(display-url *url*)

The next step is to store the data in the database. First create a suitable table:

CREATE TABLE stock_data
(
    ticker varchar(8),
    price double,
    change double,
    date datetime
)

There is a nice csv library on planet. You declare a csv reader like this:

(define make-csv-reader
  (make-csv-reader-maker
   '((separator-chars            . (#\,))
     (strip-leading-whitespace?  . #t)
     (strip-trailing-whitespace? . #t))))

Then the functions to extract the interesting data and store it in the database. The symbol, price and change from the previous day are the first, second and fifth fields respectively. I think this csv file only changes once a day so we fix the time portion of the datetime to an arbitrary value. I haven’t named the functions particularly well here, but they should convey my intent at least.

(define (db-insert-row symbol price change)
  (let ((sql (format "
    INSERT INTO stock_data
    (ticker, price, change, date)
    VALUES
    ('~a', ~a, ~a, strftime('%Y-%m-%d 06:00:00', 'now'))
    " symbol price change)))
    (print-ln sql)
    (exec/ignore *dbh* sql)))

(define (csv-insert-into-db p)
  (let ((reader (make-csv-reader p)))
    (let loop ()
      (let ((l (reader)))
        (unless (or (null? l)
                    (null? (cdr l)))
          (let ((symbol (first l))
                (price (second l))
                (change (fifth l)))
            (db-insert-row symbol price change))
          (loop))))))

And here is the complete script:

(require (lib "1.ss" "srfi")
         (lib "url.ss" "net")
         (lib "uri-codec.ss" "net")
         (planet "csv.ss" ("neil" "csv.plt" 1 1))
         (planet "sqlite.ss" ("jaymccarthy" "sqlite.plt" 3 1)))

(current-alist-separator-mode 'amp)

(define (print-ln . args)
  (for-each display args)
  (newline))

(define *url-prefix* "http://download.finance.yahoo.com/d/quotes.csv?")
(define *url* (string-append *url-prefix*
                             "s=@%5EIXIC&f=sl1d1t1c1ohgv&e=.csv&h=50"))

(define (display-url url)
  (let ((p (get-pure-port (string->url url))))
    (let loop ((line (read-line p)))
      (unless (eof-object? line)
        (print-ln line)
        (loop (read-line p))))
    (close-input-port p)))

(define make-csv-reader
  (make-csv-reader-maker
   '((separator-chars            . (#\,))
     (strip-leading-whitespace?  . #t)
     (strip-trailing-whitespace? . #t))))

(define (db-insert-row symbol price change)
  (let ((sql (format "
    INSERT INTO stock_data
    (ticker, price, change, date)
    VALUES
    ('~a', ~a, ~a, strftime('%Y-%m-%d 06:00:00', 'now'))
    " symbol price change)))
    (print-ln sql)
    (exec/ignore *dbh* sql)))

(define (csv-insert-into-db p)
  (let ((reader (make-csv-reader p)))
    (let loop ()
      (let ((l (reader)))
        (unless (or (null? l)
                    (null? (cdr l)))
          (let ((symbol (first l))
                (price (second l))
                (change (fifth l)))
            (db-insert-row symbol price change))
          (loop))))))

(define (process-html url processor)
  (let ((p (get-pure-port (string->url url))))
    (processor p)
    (close-input-port p)))

(define *path-prefix* "c:/tmp")
(define (path p)
  (string->path (string-append *path-prefix* "/" p)))

(define *dbh* (open (path "test.db")))

(process-html *url* csv-insert-into-db)

(select *dbh* "SELECT count(*) as stocks from stock_data")
(define *results* (select *dbh* "SELECT * from stock_data"))

(for-each print-ln *results*)

(close *dbh*)

Read Full Post »

This time we said that we would talk about extracting the parameters from the query string and rendering the table. The string (srfi-13) and character set (srfi-14) SRFIs make it very easy to parse the query string.

(string-tokenize *query-string* (char-set-complement (char-set #\= #\&)))

We are not quite ready to talk about passing data from one page to another so we won’t discuss this any further until next time. How about rendering the table? Concatenating strings is messy and error-prone. We need some helper functions. e.g. let’s say there was a function tag that took a tag name, some attributes and content and formatted it into HTML. How would we want that to look? Maybe something like this?

(tag 'br) --> <br/>
(tag 'a '(href "www.google.com") "google") --> <a href="www.google.com">google</a>
(tag 'tr '() (tag 'td '() "hello")) --> "<tr><td>hello</td></tr>"

First of all, we need something to convert attributes into a string. Perhaps we might want multiple attributes or an attribute may want to concatenate a number of elements together:

e.g.

(list 'href "data=" data "&xyz=" xyz)
(define (attributes->string attributes)
  (if (pair? attributes)
      (let ((h (car attributes))
            (t (cdr attributes)))
        (if (pair? h)
            (string-join (map attributes->string attributes) " ")
            (string-append (symbol->string h)
                           "="
                           (qstr (string-concatenate t)))))
      ""))

A little helper function prefixes the attributes with a space if they result in a non-empty string.

(define (prefix-space s)
  (if (and (string? s)
           (> (string-length s) 0))
      (string-append " " s) ""))

We may not want to pass all of the parameters in so only the tag name is compulsory. Everything else is passed into args as a list. We then extract the appropriate variables parameters if there are any.

(define (tag name . args)
  (let* ((s-name (symbol->string name))
         (args-len (length args))
         (s-attributes (if (>= args-len 1)
                           (attributes->string (first args)) ""))
         (s-content (if (>= args-len 2)
                        (string-concatenate (cdr args)) ""))
         (content-length (string-length s-content)))
    (string-append "<" s-name
                   (prefix-space s-attributes)
                   (if (> content-length 0)
                       (string-append ">" s-content
                                      "</" s-name ">")
                       "/>"))))

srfi-13 provides some convenience functions for concatenating lists of strings and joining strings together.

I briefly thought about providing a nicer interface with two functions providing a tag interface without attributes and with attributes respectively and delegating to a similar function to the one above.

(define (tag name . args) ...)
(define (tag-attribs name . args) ...)

Alternatively the keyword library can be used to make a nicer interface:

(require (lib "kw.ss"))

(define/kw (tag/kw tag-name #:key attributes (content ""))
  (tag tag-name attributes content))

This would then be called like this:

(print-ln (tag/kw 'x #:attributes '(a "b")))
(print-ln (tag/kw 'td #:content "hi"))

Now that we have a tag function, we can use it to render a table. A basic table is straight-forward enough. We map a render row function across each table row, joining the result with string-join. The render row maps a function that surrounds each element with <td> … </td> string-concatenates that, and surrounds that with <tr> … </tr>. We want to alternate different classes to each row and closures are great for this. We provide a function that returns a closure that returns a different id each call.

(define (id-generator ids)
  (let ((i -1)
        (ids (list->vector ids))
        (len (length ids)))
    (lambda ()
      (set! i (+ i 1))
      (vector-ref ids (remainder i len)))))

We can the use this generator to pass a different id to the row renderer for each row in the table.

(define (render-table-row row . tr-class)
  (let ((tr-attribs (if (null? tr-class) '()
                        (list 'class (car tr-class)))))
    (tag 'tr tr-attribs
         (string-concatenate (map (lambda (e) (tag 'td '() e)) row)))))

(define (render-table table . ids)
  (let ((columns (table-columns table))
        (data (table-data table))
        (f-row (if (null? ids)
                   render-table-row
                   (let ((f (id-generator (map symbol->string (car ids)))))
                     (lambda (e)
                       (render-table-row e (f)))))))
    (tag 'table '() (string-join (map f-row data) "\n"))))

And here is a little test function:

(print-ln (render-table (make-table
                         '("a" "b" "c")
                         '(("1" "2" "3")
                           ("4" "5" "6")
                           ("7" "8" "9")))
                        '(id0 id1)))

I’m not really happy with the interface yet so maybe I’ll look at fixing that next time along with passing data from one page to the next and sorting based on the columns.

Postscript: Danny Yoo mentioned an xml library I need to look into to see if it will replace (tag …) and related functions. The uri-codec library replaces a lot of the code from the earlier article.

(define *encodings-list*
  '((%20 " ")
    (+a  "&")
    (+e  "=")
    (+p  "+")
    (+q  "\"")
    (+r  "\r\n")))

(define *hash* (make-hash-table 'equal))

(for-each (lambda (e)
            (let ((k (symbol->string (car e)))
                  (v (second e)))
              (hash-table-put! *hash* k v)
              (hash-table-put! *hash* v k)))
          *encodings-list*)

(define (encode-chars regex s)
  (pregexp-replace* regex s
                    (lambda (k)
                      (hash-table-get *hash* k))))

The data-encode and data-decode functions also become simpler as they now use the uri-encode and uri-decode functions.

(define (data-encode data)
  (let ((i (open-input-string data))
        (o (open-output-bytes)))
    (deflate i o)
    (let ((r (base64-encode (get-output-bytes o))))
      (uri-encode (bytes->string/utf-8
                   (subbytes r 0 (- (bytes-length r) 2)))))))

(define (data-decode data)
  (let ((i (open-input-bytes
            (base64-decode
             (string->bytes/utf-8
              (uri-decode data)))))
        (o (open-output-string)))
    (inflate i o)
    (get-output-string o)))

Read Full Post »

Last time we were looking at encoding data. HTML has a nice way of encoding its special characters, e.g. < and > are mapped to &lt; and &gt; We can do something similar. Important characters to encode are quote, equals, ampersand and maybe a few others. Then we have to decide on a character for encoding – I like plus (+) as it doesn’t look like a special character to my eyes. As we are not planning for the future, plus and a single character should do.

First of all list all the encodings.

(define *encodings-list*
  '((+s " ")
    (+a "&")
    (+e "=")
    (+p "+")
    (+q "\"")
    (+r "\r\n")))

Then store the encodings and the reverse encodings in a hash.

(define *hash* (make-hash-table 'equal))

(for-each (lambda (e)
            (let ((k (symbol->string (car e)))
                  (v (second e)))
              (hash-table-put! *hash* k v)
              (hash-table-put! *hash* v k)))
          *encodings-list*)

pregexp-replace* is perfect for encoding and decoding.

(define (encode-chars regex s)
  (pregexp-replace* regex s
                    (lambda (k)
                      (hash-table-get *hash* k))))

This would be called like

(encode-chars "[+ &\"]|\r\n" "<a string>")

I’ve decided to compress and base64 encode my data in case it becomes really big.

(define (data-encode data)
  (let ((i (open-input-string data))
        (o (open-output-bytes)))
    (deflate i o)
    (let ((r (base64-encode (get-output-bytes o))))
      (encode-chars "[+=]|\r\n"
                    (bytes->string/utf-8
                     (subbytes r 0 (- (bytes-length r) 2)))))))

We also need a decoder that performs the inverse operation.

(define (data-decode data)
  (let ((i (open-input-bytes
            (base64-decode
             (string->bytes/utf-8
              (encode-chars "\\+." data)))))
        (o (open-output-string)))
    (inflate i o)
    (get-output-string o)))

And finally, my url looks reasonable:

(print-ln "<a href=\"ser.scm?data="
          (data-encode (object->string *data*))
          "\">next page</a><br/>")

Does decode perform the inverse of encode?

(print-ln (data-decode (data-encode (object->string *data*))))

which gives:

> (("Task" "Monday" "Tuesday" "Wednesday") ("Cooking" "1hr" "1hr" "2hrs"))

The encoded data itself looks like this:

> "BcExCsAgDEDRq4Q/mdFeoXM3oXMgUougYOjg7fteShSLjnDN4bYRylfDbSPc1UcNt41K4pyz+rv+pNByG0h5LYQjrYC1R8+e"

I fixed print-ln too – display is for human-readable stuff, print is for the computer. Next time we will have to extract the data from the query string, load the data into a variable (this shouldn’t be too difficult) and think about rendering the table. For anyone following along at home, the full script is as follows:

#!mzscheme -mqf

(require (lib "1.ss" "srfi")
         (lib "pregexp.ss")
         (lib "base64.ss" "net")
         (lib "deflate.ss")
         (lib "inflate.ss"))

(define-struct table-data (columns data))

(define (print-ln . args)
  (for-each display args)
  (newline))

(define (header type)
  (string-append "Content-type: " type "; charset=iso-8859-1~n~n"))

(printf (header "text/html"))

(define *encodings-list*
  '((%20 " ")
    (+a  "&")
    (+e  "=")
    (+p  "+")
    (+q  "\"")
    (+r  "\r\n")))

(define *hash* (make-hash-table 'equal))

(for-each (lambda (e)
            (let ((k (symbol->string (car e)))
                  (v (second e)))
              (hash-table-put! *hash* k v)
              (hash-table-put! *hash* v k)))
          *encodings-list*)

(define (blank-if-null s) (if (string? s) s ""))
(define *query-string* (blank-if-null (getenv "QUERY_STRING")))

(when (> (string-length *query-string*) 0)
      (printf "[~a]<br/>~n" *query-string*))

(define (string->object s)
  (read (open-input-string s)))

(define (object->string o)
  (let ((string-port (open-output-string)))
    (write o string-port)
    (get-output-string string-port)))

(define (manifest-string-encode s)
  (pregexp-replace* "'" s "\""))

(define (manifest-string->data s)
  (string->object (manifest-string-encode s)))

(define *data* #f)

(set! *data*
      (manifest-string->data
       "(('Task' 'Monday' 'Tuesday' 'Wednesday')
         ('Cooking' '1hr' '1hr' '2hrs'))"))

(define (encode-chars regex s)
  (pregexp-replace* regex s
                    (lambda (k)
                      (hash-table-get *hash* k))))

(define (data-encode data)
  (let ((i (open-input-string data))
        (o (open-output-bytes)))
    (deflate i o)
    (let ((r (base64-encode (get-output-bytes o))))
      (encode-chars "[+=]|\r\n"
                    (bytes->string/utf-8
                     (subbytes r 0 (- (bytes-length r) 2)))))))

(define (data-decode data)
  (let ((i (open-input-bytes
            (base64-decode
             (string->bytes/utf-8
              (encode-chars "\\+." data)))))
        (o (open-output-string)))
    (inflate i o)
    (get-output-string o)))

(print-ln "<a href=\"ser.scm?data="
          (data-encode (object->string *data*))
          "\">next page</a><br/>")

(print-ln "<a href=\"ser.scm\">Restart</a><br>")

(print-ln (data-decode (data-encode (object->string *data*))))

(exit)

Read Full Post »

Seaside has inspired me to try to write a basic HTML/CGI based grid style widget. In Seaside, that widget is called WATableReport which is described here and provides column sorting as is available in most decent GUI widget sets. My web-fu is a little rusty. Last time I was writing web code was back in the dark ages pre-servlets and nice session managing frameworks using pure CGI. This may well be available somewhere already but what the heck, let’s get started…

First of all, we need a data-type for the table data. For now we will keep it simple and just have the column names and the data which will probably be a list of lists.

(define-struct table-data (columns data))

We will need to serialise the data so we can pass it to another page through the query string. I briefly toyed with the idea of having some custom format of lists of comma seperated values surrounded by square brackets. e.g.

[Task, Monday, Tuesday, Wednesday],
[Cooking, 1hr, 1hr, 2hrs],
...

The parser tools supplied with PLT Scheme would make this fairly straight-forward. Even easier is using the read and print functions so we will go with that. I also want to be able to define a whole package of data for testing purposes and escaping every quote will be a pain so let me allow single quotes too. I had a look in the Scheme Cookbook for a simple way to transform characters within a string. string-map from srfi-13 offered a possibility, but we will almost certainly want something more powerful later so we might as well start with regexes.

(require (lib "pregexp.ss"))

(define (string-encode s)
  (pregexp-replace* "'" s "\""))

Together with a function to convert strings to scheme objects we can provide a convenience function for converting manifest strings into our data.

(define (string->object s)
  (read (open-input-string s)))

(define (string->data s)
  (string->object (string-encode s)))

(define *data* #f)

(set! *data*
      (string->data
       "(('Task' 'Monday' 'Tuesday' 'Wednesday')
         ('Cooking' '1hr' '1hr' '2hrs'))"))

Next time we will look at encoding the data so we can pass it through the query string. At the moment, we will have a small problem with quotes and a few other characters…

(define (print-ln . args)
  (for-each print args)
  (newline))

(print-ln "<a href=\"ser.scm?data=" *data* "\">next page</a>")

> "<a href=\"ser.scm?data="(("Task" "Monday" "Tuesday" "Wednesday") ("Cooking" "1hr" "1hr" "2hrs"))"\">next page</a>"

Read Full Post »

After fiddling around for a couple of minutes I found the correct incantation to get cgi scripts to work with Windows Apache. It uses the traditional Unix hash-bang line. Here we have a nice little hello world cgi:

#!mzscheme -mqf

(define *query-string* (getenv "QUERY_STRING"))

(define (header type)
  (string-append "Content-type: " type "; charset=iso-8859-1~n~n"))

(printf (header "text/html"))
(printf "Hello World~n")

(when *query-string*
      (printf "[~a]~n" *query-string*))

(exit)

But why bother with CGI when there are all these wonderful frameworks around? Isn’t that old-school? Well, I’ve been inspired by something in Seaside. I’m not thinking of porting the whole framework, no way. If I wanted to, then why not just use Seaside? No, I want to try something much smaller.

Read Full Post »

PLT Scheme provides a graphical toolkit for implementing GUIs called MrEd. At least on Windows, the result looks like a native application and was used to implement the IDE, DrScheme. As usual, the documentation is excellent.

When an application is running, it can be useful for it to output diagnostics that report on what it is currently doing, e.g. which database it connected to, or the id of a transaction that may have failed. This is normally output to a file, but it can also copy the output to a logging window, e.g. the Transcripter in Squeak, or the Java Web Start Console. How easy is it to implement a simple transcripter in PLT Scheme?

As usual, it is a good idea to decide on your API first as encapsulating everything behind an API means that we can easily change the implementation later on. I will simply provide a function (log s) where s is a string but you would probably want to have various logging levels which can be enabled or disabled at runtime.

(require (lib "42.ss" "srfi"))

;; First of all, create a text area inside a window (frame)

(define *frame* (instantiate frame% ("Transcript")))

(define *text* (instantiate text-field% ()
                 (label "")
                 (style '(multiple))
                 (parent *frame*)))

;; We need the editor belonging to the text area in order to append text to it

(define *editor* (send *text* get-editor))

;; The 'API' for accessing the Transcripter
;; This is a somewhat unrealistic implementation, but good enough for a quick example
(define (log s) (send *editor* insert s))

;; A test method, displaying 200 numbers on the transcripter
;; - this is the same as we did in Squeak

(define (200-nums)
  (time
   (do-ec (:range i 1 201)
          (log (string-append (number->string i) "n")))))

(instantiate button% ()
  (label "Execute")
  (parent *frame*)
  (callback (lambda (button event)
              (200-nums))))

(send *frame* show #t)

A couple of things. First of all, performance: When I ran this initially, the display numbers test took ~60ms. However, when I expanded the Transcripter window to a reasonable size, it took ~2000ms (2 seconds!) When I retried the same in Squeak it took around 5700ms although I’m certain it had earlier taken more than 10 seconds. This is a different computer and a different image but maybe the Squeak Transcripter isn’t so bad after all.

Secondly, it was fairly straight-forward to construct the GUI. Of course, such a simple example doesn’t really give any idea how hard it is to use MrEd to create moderately complex GUIs, but the existence of DrScheme indicates that it is at least possible.

Read Full Post »

Threading in MzScheme

This week I have been playing around with threading in MzScheme… I like it!

(thread (lambda () …))

is enough to create a thread and start it running.

You can use channels to pass data between threads safely with (make-channel), (channel-get <channel>) and (channel-put <channel> <data>).

Just to prove you can write Java in any language… say I wanted to have a connection manager. The API is pretty simple – I want to add connections and remove connections. Also, it might be useful to be able to start and stop the connection manager and display the number of connections. There are a number of ways I could implement this, e.g. have a global variable and synchronise access to put and get connections. Alternatively, I could have a thread that looks after connections and send messages to that thread via a channel. Just for fun, let me choose the second option.

The functionality is encapsulated and available through the following API.

(connection-manager-start)
(connection-manager-stop)
(connection-manager-clear-connections)
(connection-manager-show-connections)
(connection-add <input-port> <output-port>)
(connection-remove <input-port>)

If this was production code, I should put the code in a module and only make the above functions available using (provide…). Outside a module, we can of course by-pass the API and put messages in the channel directly.

;; Support function LOG

(define (pad n) (substring (number->string (+ n 100)) 1 3))

(define (now)
  (let* ((date (seconds->date (current-seconds)))
         (secs (date-second date))
         (mins (date-minute date))
         (hour (date-hour date)))
    (format "~a:~a:~a" (pad hour) (pad mins) (pad secs))))

(define (LOG . args)
  (printf "[ ~a ] : " (now))
  (for-each display args)
  (newline)
  (flush-output))

;; First of all, we define a struct for the connection which has
;; an input and an output port

(define-struct connection (input output))

;; Globals for the channel, and the thread - it is a singleton obviously

(define *connections-channel* (make-channel))
(define *connection-manager-thread* #f)

;; The actual manager function
;;   this constantly loops and accepts messages via *connections-channel*
;;   possible messages are:
;;     'stop, 'add-connection, 'remove-connection,
;;     'show-connection, 'clear-connections

(define (connection-manager)
  (letrec
      ((show-command
        (lambda (command)
          (LOG "Received command [" (symbol->string command) "]")))

       (show-connections
        (lambda (connections)
          (let* ((num (length connections))
                 (plural (not (= num 1))))
            (LOG "There "
                 (if plural "are " "is ")
                 num
                 " connection"
                 (if plural "s" "")))))

       (loop
        (lambda (connections)
          (let* ((command (channel-get *connections-channel*))
                 (head (car command)))
            (cond
             ((eq? head 'stop)
              (LOG "Connection manager stopping..."))
             ((eq? head 'add-connection)
              (loop (cons (cadr command) connections)))
             ((eq? head 'remove-connection)
              (let ((c (cadr command)))
                (LOG "Removing connection [" c "]")
                (loop (remove (lambda (e) (eqv? (connection-input e) c))
                              connections))))
             ((eq? head 'show-connections)
              (show-connections connections)
              (loop connections))
             ((eq? head 'clear-connections)
              (loop '()))
             (else
              (LOG "Error: unrecognised-command [" head "]")
              (loop connections)))))))

    (LOG "Connection manager starting...")
    (loop '())))

;; connection-manager-running? checks if the connection-manager
;; is currently running - it is a belt and braces effort

(define (connection-manager-running?)
  (and (thread? *connection-manager-thread*)
       (thread-running? *connection-manager-thread*)))

;; We always check if the connection-manager is running before
;; trying to send a message as (channel-put ...) waits until there
;; is a corresponding (channel-get ...) on another thread.  When
;; testing at the REPL, this can cause problems.  We could use an
;; asynch stream which wouldn't have this problem but I prefer
;; the explicit check

(define (connection-manager-send-message message)
  (if (connection-manager-running?)
      (channel-put *connections-channel* message)
      (begin
        (LOG "WARN - Connection manager is not currently running")
        #f)))

;; The actual API functions.  Most of these simply check if the
;; connection manager is running, and if so, put the appropriate
;; message in the channel.

(define (connection-manager-start)
  (if (connection-manager-running?)
      (LOG "WARN - The connection manager is already running")
      (set! *connection-manager-thread* (thread connection-manager))))

(define (connection-manager-stop)
  (connection-manager-send-message (list 'stop))
  (set! *connection-manager-thread* #f))

(define (connection-manager-clear-connections)
  (connection-manager-send-message (list 'clear-connections)))

(define (connection-manager-show-connections)
  (connection-manager-send-message (list 'show-connections)))

(define (connection-add input-port output-port)
  (connection-manager-send-message
   (list 'add-connection (make-connection input-port output-port))))

(define (connection-remove input-port)
  (connection-manager-send-message (list 'remove-connection input-port)))

;;; Connection Manager Test

;; The test...

(define (test-connection-manager)
  (connection-manager-start)
  (connection-manager-clear-connections)
  (connection-manager-show-connections)
  (connection-add 1 2)
  (connection-manager-show-connections)
  (connection-remove 1)
  (connection-manager-show-connections)

  (time
   (begin
     (do ((i 0 (+ i 1)))
         ((= i 100000) #t)
       (connection-add 1 2))
     (connection-manager-show-connections)))

  (connection-manager-stop))

;; (test-connection-manager)

Read Full Post »

I was unable to find any mention of a function for copying files in the Chicken documentation. However, the Chicken source does have a copy-file function in chicken-setup.scm. It is somewhat brittle as it uses the shell, relying on the fact that you are running the function from the same shell you used to build Chicken.

$ find . | egrep '.scm$' | xargs grep 'copy-file'

(define *windows-shell* (memq *windows* '(msvc mingw32)))
(define *copy-command* (if *windows-shell* 'copy "cp -r"))

(define (copy-file from to)
  (let ((from (if (pair? from) (car from) from))
	(to (if (pair? from) (make-pathname to (cadr from)) to)) )
    (ensure-directory to)
    (run (,*copy-command* ,(quotewrap from) ,(quotewrap to)) ) ) )

A solution with the Win32 function CopyFile would be more robust but would probably need some work to do a recursive copy. I don’t need the recursive functionality and fortunately, it is straight-forward to wrap using Chicken’s foreign function interface. I created a file called win32_lib.impl to keep all the syntax highlighting working.

#include "Windows.h"

#include <stdio.h>
#include <stdlib.h>
#include <string.h>

char* w32_error_message()
{
    char* buffer;

    FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER
                  | FORMAT_MESSAGE_FROM_SYSTEM
                  | FORMAT_MESSAGE_IGNORE_INSERTS,
                  NULL,
                  GetLastError(),
                  MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
                  (LPTSTR) &buffer,
                  0, NULL);

    buffer[strlen(buffer) - 2] = '';
    return buffer;
}

int w32_copy_file(const char* file1,
                  const char* file2,
                  int fail_if_exists)
{
    return CopyFile(file1, file2, fail_if_exists);
}
</pre>

The wrapper from Chicken is trivial:
(define-extension win32_lib)

#>
#include "win32_lib.impl"
<#

(define w32-error-message
  (foreign-lambda c-string* "w32_error_message"))

(define w32-copy-file
  (foreign-lambda int "w32_copy_file" c-string c-string int))

The makefile takes care of making a .dll so we can load it into csi (the Chicken REPL) for testing purposes.

all: win32_lib.dll prog.exe

prog.exe: main.scm win32_lib.scm win32_lib.impl
	csc -c main.scm
	csc -c win32_lib.scm
	csc -o prog.exe main.o win32_lib.o

win32_lib.dll: win32_lib.scm
	csc win32_lib.scm -dynamic -dll

clean:
	rm *.o prog.exe win32_lib.dll

And finally the test harness:

(declare (uses win32_lib))

(define args (cdr (argv)))
(display args)
(newline)

(define (wrap-copy-file file1 file2)
  (let ((r (w32-copy-file (car args) (cadr args) 1)))
    (if (= r 0)
        (printf "[~a]~n" (w32-error-message))
        (printf "Success!~n"))))

(wrap-copy-file (car args) (cadr args))

Read Full Post »

I had the pleasure of setting up a new Win32 development environment recently. After installing emacs, the first thing to do was to get MinGW and MSYS installed for the C and C++ compilers and a semi-reasonable shell.

MinGW can be downloaded here but it is slightly difficult to see the latest files for downloading. I think it would be better if they put clear links to at least the latest versions of MinGW and MSYS at the top of the page. Anyway, here they are (as of today – 4th March 2007).

I don’t really want to code in C or C++ outside of work if I can really help it, so the next thing to do is to install a friendlier language. I’m quite comfortable with scheme so I’ll use Chicken for the ability to create Win32 executables although in reality there are many acceptable alternatives here. Chicken is available here and it requires CMake to build.

As of version 2.6, Chicken seems to have improved significantly since I last looked at it. Only a C compiler is required to build it rather than an existing Chicken compiler which makes the bootstrapping procedure somewhat easier. I installed it to c:/chicken, set the PATH and CHICKEN_HOME environment variables and compiled my first test program on this machine. Very nice and straightforward.

Read Full Post »

Older Posts »

Follow

Get every new post delivered to your Inbox.