diff --git a/contrib/cont-responder/browser.factor b/contrib/cont-responder/browser.factor index db7c92df5d..3431dd0e4d 100644 --- a/contrib/cont-responder/browser.factor +++ b/contrib/cont-responder/browser.factor @@ -45,6 +45,7 @@ USE: errors USE: unparser USE: logging USE: listener +USE: url-encoding : ( allow-edit? vocab word -- ) #! An object for storing the current browser @@ -187,6 +188,15 @@ USE: listener ] when* ] catch ; +: browser-url ( vocab word -- url ) + #! Given a vocabulary and word as strings, return a browser + #! URL which, when requested, will display the source to that + #! word. + [ + ".?word=" , url-encode , + "&vocab=" , url-encode , + ] make-string ; + : browse ( -- ) #! Display a Smalltalk like browser for exploring/modifying words. [ @@ -213,15 +223,22 @@ USE: listener ] extend ] bind [ "allow-edit?" get - "vocabs" get - "words" get + "vocabs" get + "words" get "eval" get dup [ "vocabs" get swap eval-string ] [ drop ] ifte + [ + "vocabs" get "words" get browser-url forward-to-url + ] show ] bind ] forever ; : browser-responder ( allow-edit? -- ) #! Start the Smalltalk-like browser. - "browser" f browse ; + "query" get dup [ + dup >r "vocab" swap assoc r> "word" swap assoc + ] [ + drop "browser" f + ] ifte browse ; "browser" [ f browser-responder ] install-cont-responder -!"browser-edit" [ t browser-responder ] install-cont-responder +! "browser-edit" [ t browser-responder ] install-cont-responder diff --git a/contrib/cont-responder/cont-responder.factor b/contrib/cont-responder/cont-responder.factor index 410123a47d..a5995e72cc 100644 --- a/contrib/cont-responder/cont-responder.factor +++ b/contrib/cont-responder/cont-responder.factor @@ -39,7 +39,7 @@ USE: logging USE: url-encoding USE: unparser USE: hashtables - +USE: parser USE: prettyprint USE: inspector @@ -58,7 +58,7 @@ USE: inspector : get-random-id ( -- id ) #! Generate a random id to use for continuation URL's - [ 16 [ random-digit unparse , ] times ] make-string ; + [ 32 [ random-digit unparse , ] times ] make-string str>number 36 >base ; : continuation-table ( -- ) #! Return the global table of continuations @@ -127,6 +127,11 @@ USE: inspector #! Get the continuation item associated with the id. continuation-table [ get ] bind ; +: id>url ( id -- string ) + #! Convert the continuation id to an URL suitable for + #! embedding in an HREF or other HTML. + url-encode "?id=" swap cat2 ; + DEFER: show : expired-page-handler ( alist -- ) @@ -195,6 +200,15 @@ DEFER: show #! stream. Return the string on exit. 1024 dup >r swap with-stream r> stream>str ; +: forward-to-url ( url -- ) + #! When executed inside a 'show' call, this will force a + #! HTTP 302 to occur to instruct the browser to forward to + #! the request URL. + [ + "HTTP/1.1 302 Document Moved\nLocation: " , , + "\nContent-Length: 0\nContent-Type: text/plan\n\n" , + ] make-string call-exit-continuation ; + : redirect-to-here ( -- ) #! Force a redirect to the client browser so that the browser #! goes to the current point in the code. This forces an URL @@ -208,7 +222,7 @@ DEFER: show ] [ [ t swap register-continuation - [ "HTTP/1.1 302 Document Moved\nLocation: " , , "\n" , + [ "HTTP/1.1 302 Document Moved\nLocation: " , id>url , "\n" , "Content-Length: 0\nContent-Type: text/plain\n\n" , ] make-string call-exit-continuation ] callcc1 drop @@ -226,7 +240,7 @@ DEFER: show store-callback-cc redirect-enabled? [ redirect-to-here ] when [ - t swap register-continuation swap + t swap register-continuation id>url swap [ serving-html ] car swons with-string-stream call-exit-continuation ] callcc1 @@ -235,6 +249,8 @@ DEFER: show : cont-get-responder ( id-or-f -- ) #! httpd responder that retrieves a continuation and calls it. + drop + "id" "query" get assoc dup f-or-"" [ #! No continuation id given drop "root-continuation" get dup [ @@ -255,7 +271,9 @@ DEFER: show #! id and calls it with the POST data as a hashtable on the top #! of the stack. [ - "response" get alist>hash swap resume-continuation + drop + "response" get alist>hash + "id" "query" get assoc resume-continuation ] with-exit-continuation print drop ; @@ -271,7 +289,7 @@ DEFER: show #! back to the most recent 'show' call (via the callback-cc). #! The text of the link will be the 'text' argument on the #! stack. - write ; + url a> write ; : with-new-session ( quot -- ) #! Each cont-responder is bound inside their own diff --git a/contrib/cont-responder/cont-testing.factor b/contrib/cont-responder/cont-testing.factor index 38030774c4..899b8b3712 100644 --- a/contrib/cont-responder/cont-testing.factor +++ b/contrib/cont-responder/cont-testing.factor @@ -39,7 +39,7 @@ ! eg. ! [ test-cont-responder ] test-cont-function ! => HTTP/1.1 302 Document Moved -! Location: 8506502852110820 +! Location: ?id=8506502852110820 ! Content-Length: 0 ! Content-Type: text/plain ! @@ -48,12 +48,12 @@ ! Content-Type: text/html ! ! Page one -!

Page one

Next +!

Page one

Next ! ! ! "5431597582800278" f test-cont-click ! => HTTP/1.1 302 Document Moved -! Location: 7944183606904129 +! Location: ?id=7944183606904129 ! Content-Length: 0 ! Content-Type: text/plain ! @@ -63,14 +63,14 @@ ! ! Enter your name !

Enter your name

-!
-! Name: -! +! +! Name: +! !
! -! "8503790719833723" [ [ "name" | "Chris" ] ] alist>hash test-cont-click +! "8503790719833723" [ [[ "name" "Chris" ]] ] alist>hash test-cont-click ! => HTTP/1.1 302 Document Moved -! Location: 8879727708050260 +! Location: ?id=8879727708050260 ! Content-Length: 0 ! Content-Type: text/plain ! @@ -80,7 +80,7 @@ ! ! Hello Chris !

Hello Chris

-! Next +! Next ! ! ! etc. diff --git a/contrib/cont-responder/live-updater.factor b/contrib/cont-responder/live-updater.factor index 40a36c9bd6..d043398347 100644 --- a/contrib/cont-responder/live-updater.factor +++ b/contrib/cont-responder/live-updater.factor @@ -47,7 +47,7 @@ USE: lists [ "js/liveUpdater.js" get-live-updater-js write ] show - ] register-continuation ; + ] register-continuation id>url ; : include-live-updater-js ( -- ) #! Write out the HTML script to include the live updater @@ -96,7 +96,7 @@ USE: lists "document.getElementById('" write write "').onclick=liveUpdaterUri('" write - register-live-anchor-quot write + register-live-anchor-quot id>url write "');" write ; @@ -153,7 +153,7 @@ USE: lists "liveSearch('" write write "', '" write - register-live-search-quot write + register-live-search-quot id>url write "');" write ; diff --git a/contrib/cont-responder/todo-example.factor b/contrib/cont-responder/todo-example.factor index 1bdf64f44a..591878f9f3 100644 --- a/contrib/cont-responder/todo-example.factor +++ b/contrib/cont-responder/todo-example.factor @@ -107,7 +107,7 @@ USE: kernel : todo-stylesheet-url ( -- url ) #! Generate an URL for the stylesheet. - t [ [ drop todo-stylesheet write ] show ] register-continuation ; + t [ [ drop todo-stylesheet write ] show ] register-continuation id>url ; : include-todo-stylesheet ( -- ) #! Generate HTML to include the todo stylesheet diff --git a/contrib/cont-responder/tutorial.txt b/contrib/cont-responder/tutorial.txt index 7373c464b0..fd1e9ef53d 100644 --- a/contrib/cont-responder/tutorial.txt +++ b/contrib/cont-responder/tutorial.txt @@ -331,10 +331,10 @@ sequence the page shows. Any Factor code can be called and the continuation based system will sequentially display each page. The back button, browser window cloning, etc will all continue to work. -You'll notice the URL's in the browser have a number at the end of -them. This is the 'continuation identifier' which is like a session id -except that it identifies not just the data you have stored but your -location within the responder as well. +You'll notice the URL's in the browser have an 'id' query parameter with +a number as its value. This is the 'continuation identifier' which is +like a session id except that it identifies not just the data you have +stored but your location within the responder as well. Forms and POST data =================== @@ -603,7 +603,7 @@ calls the code we want to test and call the 'test-cont-function' word: [ subroutine-example1 ] test-cont-function => HTTP/1.1 302 Document Moved - Location: 8209741119458310 + Location: ?id=8209741119458310 Content-Length: 0 Content-Type: text/plain @@ -628,9 +628,9 @@ state on the stack: Content-Type: text/html Subroutine Example 1

Please select: -

  1. Flow1
    2. -
  2. Flow2
    3. -
  3. Flow3
    4. +
    1. Flow1
      2. +
    2. Flow2
      3. +
    3. Flow3

    @@ -645,7 +645,7 @@ written previously: [ post-example1 ] test-cont-function => HTTP/1.1 302 Document Moved - Location: 5829759941409535 + Location: ?id=5829759941409535 Content-Length: 0 Content-Type: text/plain @@ -658,7 +658,7 @@ Again we skip past the forward: Please enter your name -
    +

    Please enter your name: diff --git a/contrib/sqlite/sqlite.factor b/contrib/sqlite/sqlite.factor index 3dee2a3753..bde8be34e3 100644 --- a/contrib/sqlite/sqlite.factor +++ b/contrib/sqlite/sqlite.factor @@ -28,10 +28,6 @@ ! Not all functions have been wrapped yet. Only those directly involving ! executing SQL calls and obtaining results. ! -! TODO: Do I have to free stuctures like and , etc -! or do they get freed on garbage collection? -! How do I do pointers to pointers? Use the 'indirect' trick? -! IN: sqlite USE: kernel USE: alien @@ -98,77 +94,58 @@ END-STRUCT : SQLITE_TRANSIENT -1 ; : sqlite3_open ( filename sqlite3-indirect -- result ) - "int" "sqlite" "sqlite3_open" [ "char*" "sqlite3-indirect*" ] alien-invoke ; + "int" "sqlite" "sqlite3_open" [ "char*" "sqlite3-indirect*" ] alien-invoke ; compiled : sqlite3_close ( db -- ) - "int" "sqlite" "sqlite3_close" [ "sqlite3*" ] alien-invoke ; + "int" "sqlite" "sqlite3_close" [ "sqlite3*" ] alien-invoke ; compiled : sqlite3_prepare ( db sql sql-len sqlite3-stmt-indirect tail -- result ) - "int" "sqlite" "sqlite3_prepare" [ "sqlite3*" "char*" "int" "sqlite3-stmt-indirect*" "char*-indirect*" ] alien-invoke ; + "int" "sqlite" "sqlite3_prepare" [ "sqlite3*" "char*" "int" "sqlite3-stmt-indirect*" "char*-indirect*" ] alien-invoke ; compiled : sqlite3_finalize ( stmt -- result ) - "int" "sqlite" "sqlite3_finalize" [ "sqlite3-stmt*" ] alien-invoke ; + "int" "sqlite" "sqlite3_finalize" [ "sqlite3-stmt*" ] alien-invoke ; compiled : sqlite3_reset ( stmt -- result ) - "int" "sqlite" "sqlite3_reset" [ "sqlite3-stmt*" ] alien-invoke ; + "int" "sqlite" "sqlite3_reset" [ "sqlite3-stmt*" ] alien-invoke ; compiled : sqlite3_step ( stmt -- result ) - "int" "sqlite" "sqlite3_step" [ "sqlite3-stmt*" ] alien-invoke ; + "int" "sqlite" "sqlite3_step" [ "sqlite3-stmt*" ] alien-invoke ; compiled : sqlite3_bind_blob ( stmt index pointer len destructor -- result ) - "int" "sqlite" "sqlite3_bind_blob" [ "sqlite3-stmt*" "int" "void*" "int" "int" ] alien-invoke ; + "int" "sqlite" "sqlite3_bind_blob" [ "sqlite3-stmt*" "int" "void*" "int" "int" ] alien-invoke ; compiled : sqlite3_bind_int ( stmt index int -- result ) - "int" "sqlite" "sqlite3_bind_int" [ "sqlite3-stmt*" "int" "int" ] alien-invoke ; + "int" "sqlite" "sqlite3_bind_int" [ "sqlite3-stmt*" "int" "int" ] alien-invoke ; compiled : sqlite3_bind_null ( stmt index -- result ) - "int" "sqlite" "sqlite3_bind_null" [ "sqlite3-stmt*" "int" ] alien-invoke ; + "int" "sqlite" "sqlite3_bind_null" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled : sqlite3_bind_text ( stmt index text len destructor -- result ) - "int" "sqlite" "sqlite3_bind_text" [ "sqlite3-stmt*" "int" "char*" "int" "int" ] alien-invoke ; + "int" "sqlite" "sqlite3_bind_text" [ "sqlite3-stmt*" "int" "char*" "int" "int" ] alien-invoke ; compiled : sqlite3_column_count ( stmt -- count ) - "int" "sqlite" "sqlite3_column_count" [ "sqlite3-stmt*" ] alien-invoke ; + "int" "sqlite" "sqlite3_column_count" [ "sqlite3-stmt*" ] alien-invoke ; compiled : sqlite3_column_blob ( stmt col -- void* ) - "void*" "sqlite" "sqlite3_column_blob" [ "sqlite3-stmt*" "int" ] alien-invoke ; + "void*" "sqlite" "sqlite3_column_blob" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled : sqlite3_column_bytes ( stmt col -- int ) - "int" "sqlite" "sqlite3_column_bytes" [ "sqlite3-stmt*" "int" ] alien-invoke ; + "int" "sqlite" "sqlite3_column_bytes" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled : sqlite3_column_decltype ( stmt col -- string ) - "char*" "sqlite" "sqlite3_column_decltype" [ "sqlite3-stmt*" "int" ] alien-invoke ; + "char*" "sqlite" "sqlite3_column_decltype" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled : sqlite3_column_int ( stmt col -- int ) - "int" "sqlite" "sqlite3_column_int" [ "sqlite3-stmt*" "int" ] alien-invoke ; + "int" "sqlite" "sqlite3_column_int" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled : sqlite3_column_name ( stmt col -- string ) - "char*" "sqlite" "sqlite3_column_name" [ "sqlite3-stmt*" "int" ] alien-invoke ; + "char*" "sqlite" "sqlite3_column_name" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled : sqlite3_column_text ( stmt col -- string ) - "char*" "sqlite" "sqlite3_column_text" [ "sqlite3-stmt*" "int" ] alien-invoke ; + "char*" "sqlite" "sqlite3_column_text" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled : sqlite3_column_type ( stmt col -- int ) - "int" "sqlite" "sqlite3_column_type" [ "sqlite3-stmt*" "int" ] alien-invoke ; - -\ sqlite3_open compile -\ sqlite3_close compile -\ sqlite3_prepare compile -\ sqlite3_finalize compile -\ sqlite3_reset compile -\ sqlite3_bind_blob compile -\ sqlite3_bind_int compile -\ sqlite3_bind_null compile -\ sqlite3_bind_text compile -\ sqlite3_step compile -\ sqlite3_column_count compile -\ sqlite3_column_blob compile -\ sqlite3_column_bytes compile -\ sqlite3_column_decltype compile -\ sqlite3_column_int compile -\ sqlite3_column_name compile -\ sqlite3_column_text compile -\ sqlite3_column_type compile + "int" "sqlite" "sqlite3_column_type" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled ! High level sqlite routines : sqlite-check-result ( result -- ) @@ -220,26 +197,32 @@ END-STRUCT #! from zero, as a string. sqlite3_column_text ; -: (sqlite-each) - "statement" get sqlite3_step dup SQLITE_ROW = [ - drop - "statement" get "quot" get call (sqlite-each) - ] [ +: step-complete? ( step-result -- bool ) + #! Return true if the result of a sqlite3_step is + #! such that the iteration has completed (ie. it is + #! SQLITE_DONE). Throw an error if an error occurs. + dup SQLITE_ROW = [ + drop f + ] [ dup SQLITE_DONE = [ - drop + drop t ] [ sqlite-check-result - ] ifte + ] ifte ] ifte ; : sqlite-each ( statement quot -- ) - #! Excecute the SQL statement, and call the quotation for + #! Execute the SQL statement, and call the quotation for #! each row returned from executing the statement with the #! statement on the top of the stack. - #! TODO: Implement without named parameters - [ - "quot" set - "statement" set - (sqlite-each) - ] bind ; + over sqlite3_step step-complete? [ + 2drop + ] [ + 2dup 2slip sqlite-each + ] ifte ; +! For comparison, here is the linrec implementation of sqlite-each +! [ drop sqlite3_step step-complete? ] +! [ 2drop ] +! [ 2dup 2slip ] +! [ ] linrec ; \ No newline at end of file diff --git a/contrib/sqlite/test.factor b/contrib/sqlite/test.factor index 8257c655b3..59be1583cf 100644 --- a/contrib/sqlite/test.factor +++ b/contrib/sqlite/test.factor @@ -47,4 +47,9 @@ USE: prettyprint sqlite-finalize sqlite-close ; +: run-test2 ( -- ) + "test.db" sqlite-open + dup "select * from test" sqlite-prepare + dup [ show-people ] ; + run-test \ No newline at end of file