From 47ef542e92c1faffa536c4680e97e19a506184ae Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 24 Nov 2008 10:18:47 +0100 Subject: [PATCH 01/30] Emacs factor mode: defun and sexp navigation are aware of word definition syntax. --- misc/factor.el | 29 ++++++++++++++++++++--------- 1 file changed, 20 insertions(+), 9 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index 3c5b6bb544..c8e637f268 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -204,7 +204,7 @@ buffer." (defconst factor--regex-using-line "^USING: +\\([^;]*\\);") (defconst factor--regex-use-line "^USE: +\\(.*\\)$") -(defconst factor-font-lock-keywords +(defconst factor--font-lock-keywords `(("( .* )" . 'factor-font-lock-stack-effect) ("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word) ,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)") @@ -502,17 +502,25 @@ buffer." (use-local-map factor-mode-map) (setq major-mode 'factor-mode) (setq mode-name "Factor") + ;; Font locking (set (make-local-variable 'comment-start) "! ") + (set (make-local-variable 'parse-sexp-lookup-properties) t) (set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment) (set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string) (set (make-local-variable 'font-lock-defaults) - `(factor-font-lock-keywords + `(factor--font-lock-keywords nil nil nil nil (font-lock-syntactic-keywords . ,factor--font-lock-syntactic-keywords))) + (set-syntax-table factor-mode-syntax-table) + ;; Defun navigation + (setq defun-prompt-regexp "[^ :]+") + (set (make-local-variable 'open-paren-in-column-0-is-defun-start) t) + ;; Indentation (set (make-local-variable 'indent-line-function) 'factor--indent-line) (setq factor-indent-width (factor--guess-indent-width)) (setq indent-tabs-mode nil) + (run-hooks 'factor-mode-hook)) (add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) @@ -568,6 +576,7 @@ buffer." "Generic word contract" "Inputs and outputs" "Parent topics:" + "See also" "Syntax" "Vocabulary" "Warning" @@ -578,7 +587,7 @@ buffer." (defconst factor--help-font-lock-keywords `((,factor--help-headlines-regexp . 'factor-font-lock-help-mode-headlines) - ,@factor-font-lock-keywords)) + ,@factor--font-lock-keywords)) (defun factor-help-mode () "Major mode for displaying Factor help messages. @@ -591,6 +600,7 @@ buffer." (set (make-local-variable 'font-lock-defaults) '(factor--help-font-lock-keywords t nil nil nil)) (set (make-local-variable 'comint-redirect-subvert-readonly) t) + (set (make-local-variable 'comint-redirect-echo-input) nil) (set (make-local-variable 'view-no-disable-on-exit) t) (view-mode) (setq view-exit-action @@ -602,11 +612,11 @@ buffer." (run-mode-hooks 'factor-help-mode-hook)) (defun factor--listener-help-buffer () - (set-buffer (get-buffer-create "*factor-help*")) - (let ((inhibit-read-only t)) - (delete-region (point-min) (point-max))) - (factor-help-mode) - (current-buffer)) + (with-current-buffer (get-buffer-create "*factor-help*") + (let ((inhibit-read-only t)) + (delete-region (point-min) (point-max))) + (factor-help-mode) + (current-buffer))) (defvar factor--help-history nil) @@ -622,7 +632,8 @@ buffer." (hb (factor--listener-help-buffer)) (proc (factor--listener-process))) (comint-redirect-send-command-to-process cmd hb proc nil) - (pop-to-buffer hb))) + (pop-to-buffer hb) + (beginning-of-buffer hb))) (defun factor-see () (interactive) From c4f8da0510390935d4debdcc038ce102335197c4 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 24 Nov 2008 22:44:05 +0100 Subject: [PATCH 02/30] Emacs factor mode: better defaults for font-lock faces. --- misc/factor.el | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index c8e637f268..6c9faf50c9 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -109,49 +109,47 @@ buffer." :group 'factor :group 'faces) -(defsubst factor--face (face) `((t ,(face-attr-construct face)))) - -(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face) +(defface factor-font-lock-parsing-word (face-default-spec font-lock-keyword-face) "Face for parsing words." :group 'factor-faces) -(defface factor-font-lock-comment (factor--face font-lock-comment-face) +(defface factor-font-lock-comment (face-default-spec font-lock-comment-face) "Face for comments." :group 'factor-faces) -(defface factor-font-lock-string (factor--face font-lock-string-face) +(defface factor-font-lock-string (face-default-spec font-lock-string-face) "Face for strings." :group 'factor-faces) -(defface factor-font-lock-stack-effect (factor--face font-lock-comment-face) +(defface factor-font-lock-stack-effect (face-default-spec font-lock-comment-face) "Face for stack effect specifications." :group 'factor-faces) -(defface factor-font-lock-word-definition (factor--face font-lock-function-name-face) +(defface factor-font-lock-word-definition (face-default-spec font-lock-function-name-face) "Face for word, generic or method being defined." :group 'factor-faces) -(defface factor-font-lock-symbol-definition (factor--face font-lock-variable-name-face) +(defface factor-font-lock-symbol-definition (face-default-spec font-lock-variable-name-face) "Face for name of symbol being defined." :group 'factor-faces) -(defface factor-font-lock-vocabulary-name (factor--face font-lock-constant-face) +(defface factor-font-lock-vocabulary-name (face-default-spec font-lock-constant-face) "Face for names of vocabularies in USE or USING." :group 'factor-faces) -(defface factor-font-lock-type-definition (factor--face font-lock-type-face) +(defface factor-font-lock-type-definition (face-default-spec font-lock-type-face) "Face for type (tuple) names." :group 'factor-faces) -(defface factor-font-lock-constructor (factor--face font-lock-type-face) +(defface factor-font-lock-constructor (face-default-spec font-lock-type-face) "Face for constructors ()." :group 'factor-faces) -(defface factor-font-lock-setter-word (factor--face font-lock-function-name-face) +(defface factor-font-lock-setter-word (face-default-spec font-lock-function-name-face) "Face for setter words (>>foo)." :group 'factor-faces) -(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face) +(defface factor-font-lock-parsing-word (face-default-spec font-lock-keyword-face) "Face for parsing words." :group 'factor-faces) From b19e87ea7587b2842041f6b7fa1237a2fbe20cdd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 16:28:35 -0600 Subject: [PATCH 03/30] Fix corner case where auto-use didn't print using list --- core/generic/parser/parser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor index c6420164d2..0852459c34 100644 --- a/core/generic/parser/parser.factor +++ b/core/generic/parser/parser.factor @@ -16,7 +16,7 @@ ERROR: not-in-a-method-error ; SYMBOL: current-method : with-method-definition ( method quot -- ) - [ dup current-method ] dip with-variable ; inline + over current-method set call current-method off ; inline : (M:) ( method def -- ) CREATE-METHOD [ parse-definition ] with-method-definition ; From 12d4f684ec6dd314168efe13132518935e60c2fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 16:28:56 -0600 Subject: [PATCH 04/30] Fix , , *long, *ulong on win64 --- basis/alien/c-types/c-types-tests.factor | 4 ++++ basis/cpu/x86/64/winnt/winnt.factor | 4 ++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index edda9e7fdb..5c4f022e93 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -56,3 +56,7 @@ TYPEDEF: uchar* MyLPBYTE ] must-fail [ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test + +os windows? cpu x86.64? and [ + [ -2147467259 ] [ 2147500037 *long ] unit-test +] when diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index 9108c0e8f7..629ba23e06 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -23,6 +23,6 @@ M: x86.64 dummy-fp-params? t ; << "longlong" "ptrdiff_t" typedef "longlong" "intptr_t" typedef -"int" "long" typedef -"uint" "ulong" typedef +"int" c-type "long" define-primitive-type +"uint" c-type "ulong" define-primitive-type >> From 499cc882ac9c90b765a2c1451c2d7257e2c083c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 16:49:50 -0600 Subject: [PATCH 05/30] Make scp and ssh commands configurable --- extra/mason/common/common.factor | 8 +++++--- extra/mason/config/config.factor | 9 ++++++++- extra/mason/release/branch/branch-tests.factor | 1 + extra/mason/release/branch/branch.factor | 5 ++--- 4 files changed, 16 insertions(+), 7 deletions(-) diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index fc7149e181..49f280fa84 100644 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -15,9 +15,11 @@ IN: mason.common :: upload-safely ( local username host remote -- ) [let* | temp [ remote ".incomplete" append ] - scp-remote [ { username "@" host ":" temp } concat ] | - { "scp" local scp-remote } short-running-process - { "ssh" host "-l" username "mv" temp remote } short-running-process + scp-remote [ { username "@" host ":" temp } concat ] + scp [ scp-command get ] + ssh [ ssh-command get ] | + { scp local scp-remote } short-running-process + { ssh host "-l" username "mv" temp remote } short-running-process ] ; : eval-file ( file -- obj ) diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor index e4ef127413..9169fbf196 100644 --- a/extra/mason/config/config.factor +++ b/extra/mason/config/config.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: system io.files namespaces kernel accessors ; +USING: system io.files namespaces kernel accessors assocs ; IN: mason.config ! (Optional) Location for build directories @@ -77,3 +77,10 @@ SYMBOL: upload-username ! Directory with binary packages. SYMBOL: upload-directory + +! Optional: override ssh and scp command names +SYMBOL: scp-command +scp-command global [ "scp" or ] change-at + +SYMBOL: ssh-command +ssh-command global [ "ssh" or ] change-at diff --git a/extra/mason/release/branch/branch-tests.factor b/extra/mason/release/branch/branch-tests.factor index ae3ddb61fc..463f8b13c1 100644 --- a/extra/mason/release/branch/branch-tests.factor +++ b/extra/mason/release/branch/branch-tests.factor @@ -14,6 +14,7 @@ USING: mason.release.branch mason.config tools.test namespaces ; [ { "scp" "boot.unix-x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [ [ + "scp" scp-command set "joe" image-username set "blah.com" image-host set "/stuff/clean" image-directory set diff --git a/extra/mason/release/branch/branch.factor b/extra/mason/release/branch/branch.factor index ff2632a9b3..600b08c6b6 100644 --- a/extra/mason/release/branch/branch.factor +++ b/extra/mason/release/branch/branch.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces sequences prettyprint io.files -io.launcher make -mason.common mason.platform mason.config ; +io.launcher make mason.common mason.platform mason.config ; IN: mason.release.branch : branch-name ( -- string ) "clean-" platform append ; @@ -25,7 +24,7 @@ IN: mason.release.branch : upload-clean-image-cmd ( -- args ) [ - "scp" , + scp-command get , boot-image-name , [ image-username get % "@" % From bb99523d39acbbf3f5ca314280fa36679bc1ff81 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Mon, 24 Nov 2008 18:55:45 -0600 Subject: [PATCH 06/30] Fix Windows UI --- basis/ui/windows/windows.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 512930d06d..99a7d5fe0f 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -9,7 +9,7 @@ windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads libc combinators combinators.short-circuit continuations command-line shuffle opengl ui.render ascii math.bitwise locals symbols accessors -math.geometry.rect math.order ascii ; +math.geometry.rect math.order ascii calendar ; IN: ui.windows SINGLETON: windows-ui-backend @@ -472,7 +472,7 @@ M: windows-ui-backend do-events "MSG" malloc-object msg-obj set-global "Factor-window" utf16n malloc-string class-name-ptr set-global register-wndclassex drop - GetDoubleClickTime double-click-timeout set-global ; + GetDoubleClickTime milliseconds double-click-timeout set-global ; : cleanup-win32-ui ( -- ) class-name-ptr get-global [ dup f UnregisterClass drop free ] when* From b045a39333daa4ed7b315f31c1ee80ae9494f502 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 20:26:11 -0600 Subject: [PATCH 07/30] Re-arrange furnce to avoid circularity --- basis/furnace/actions/actions.factor | 2 +- basis/furnace/asides/asides.factor | 2 +- basis/furnace/auth/auth.factor | 2 +- .../recover-password/recover-password.factor | 9 +- .../features/registration/registration.factor | 2 +- basis/furnace/auth/login/login.factor | 1 - basis/furnace/boilerplate/boilerplate.factor | 5 +- basis/furnace/chloe-tags/chloe-tags.factor | 2 +- .../conversations/conversations.factor | 2 +- basis/furnace/furnace-docs.factor | 123 ----------------- basis/furnace/furnace-tests.factor | 4 +- basis/furnace/furnace.factor | 126 ----------------- basis/furnace/redirection/redirection.factor | 2 +- basis/furnace/referrer/referrer-docs.factor | 2 +- basis/furnace/referrer/referrer.factor | 2 +- basis/furnace/sessions/sessions-tests.factor | 3 +- basis/furnace/sessions/sessions.factor | 10 +- basis/furnace/syndication/syndication.factor | 7 +- basis/furnace/utilities/utilities-docs.factor | 126 +++++++++++++++++ basis/furnace/utilities/utilities.factor | 128 +++++++++++++++++- extra/webapps/wiki/wiki.factor | 2 +- 21 files changed, 280 insertions(+), 282 deletions(-) create mode 100644 basis/furnace/utilities/utilities-docs.factor diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index 6c56a8ad7b..72a7b76d23 100644 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -6,7 +6,7 @@ io arrays math boxes splitting urls xml.entities http.server http.server.responses -furnace +furnace.utilities furnace.redirection furnace.conversations html.forms diff --git a/basis/furnace/asides/asides.factor b/basis/furnace/asides/asides.factor index 6d4196cf0b..7489d19f94 100644 --- a/basis/furnace/asides/asides.factor +++ b/basis/furnace/asides/asides.factor @@ -4,9 +4,9 @@ USING: namespaces assocs kernel sequences accessors hashtables urls db.types db.tuples math.parser fry logging combinators html.templates.chloe.syntax http http.server http.server.filters http.server.redirection -furnace furnace.cache furnace.sessions +furnace.utilities furnace.redirection ; IN: furnace.asides diff --git a/basis/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor index 1b5c5f9e73..b9c961941c 100644 --- a/basis/furnace/auth/auth.factor +++ b/basis/furnace/auth/auth.factor @@ -8,8 +8,8 @@ html.forms http.server http.server.filters http.server.dispatchers -furnace furnace.actions +furnace.utilities furnace.redirection furnace.boilerplate furnace.auth.providers diff --git a/basis/furnace/auth/features/recover-password/recover-password.factor b/basis/furnace/auth/features/recover-password/recover-password.factor index 5885aaef61..77be30a2d1 100644 --- a/basis/furnace/auth/features/recover-password/recover-password.factor +++ b/basis/furnace/auth/features/recover-password/recover-password.factor @@ -1,11 +1,10 @@ ! Copyright (c) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces make accessors kernel assocs arrays io.sockets -threads fry urls smtp validators html.forms present -http http.server.responses http.server.redirection -http.server.dispatchers -furnace furnace.actions furnace.auth furnace.auth.providers -furnace.redirection ; +threads fry urls smtp validators html.forms present http +http.server.responses http.server.redirection +http.server.dispatchers furnace.actions furnace.auth +furnace.auth.providers furnace.redirection furnace.utilities ; IN: furnace.auth.features.recover-password SYMBOL: lost-password-from diff --git a/basis/furnace/auth/features/registration/registration.factor b/basis/furnace/auth/features/registration/registration.factor index 0484c11727..7f73f0c404 100644 --- a/basis/furnace/auth/features/registration/registration.factor +++ b/basis/furnace/auth/features/registration/registration.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel namespaces validators html.forms urls http.server.dispatchers -furnace furnace.auth furnace.auth.providers furnace.actions +furnace.auth furnace.auth.providers furnace.actions furnace.redirection ; IN: furnace.auth.features.registration diff --git a/basis/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor index 4fc4e7e8be..fff301eb2f 100644 --- a/basis/furnace/auth/login/login.factor +++ b/basis/furnace/auth/login/login.factor @@ -3,7 +3,6 @@ USING: kernel accessors namespaces sequences math.parser calendar validators urls logging html.forms http http.server http.server.dispatchers -furnace furnace.auth furnace.asides furnace.actions diff --git a/basis/furnace/boilerplate/boilerplate.factor b/basis/furnace/boilerplate/boilerplate.factor index 946372e1f8..95e93f2ee8 100644 --- a/basis/furnace/boilerplate/boilerplate.factor +++ b/basis/furnace/boilerplate/boilerplate.factor @@ -1,12 +1,13 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math.order namespaces furnace combinators.short-circuit +USING: accessors kernel math.order namespaces combinators.short-circuit html.forms html.templates html.templates.chloe locals http.server -http.server.filters ; +http.server.filters +furnace.utilities ; IN: furnace.boilerplate TUPLE: boilerplate < filter-responder template init ; diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index 697c885a01..8ab70ded7b 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -19,7 +19,7 @@ http http.server http.server.redirection http.server.responses -furnace ; +furnace.utilities ; QUALIFIED-WITH: assocs a IN: furnace.chloe-tags diff --git a/basis/furnace/conversations/conversations.factor b/basis/furnace/conversations/conversations.factor index 671296ce57..266958c8a4 100644 --- a/basis/furnace/conversations/conversations.factor +++ b/basis/furnace/conversations/conversations.factor @@ -4,10 +4,10 @@ USING: namespaces assocs kernel sequences accessors hashtables urls db.types db.tuples math.parser fry logging combinators html.templates.chloe.syntax http http.server http.server.filters http.server.redirection -furnace furnace.cache furnace.scopes furnace.sessions +furnace.utilities furnace.redirection ; IN: furnace.conversations diff --git a/basis/furnace/furnace-docs.factor b/basis/furnace/furnace-docs.factor index 911433d100..c6191b295e 100644 --- a/basis/furnace/furnace-docs.factor +++ b/basis/furnace/furnace-docs.factor @@ -2,129 +2,6 @@ USING: assocs help.markup help.syntax kernel quotations sequences strings urls xml.data http ; IN: furnace -HELP: adjust-redirect-url -{ $values { "url" url } { "url'" url } } -{ $description "Adjusts a redirection URL by filtering the URL's query parameters through the " { $link modify-redirect-query } " generic word on every responder involved in handling the current request." } ; - -HELP: adjust-url -{ $values { "url" url } { "url'" url } } -{ $description "Adjusts a link URL by filtering the URL's query parameters through the " { $link modify-query } " generic word on every responder involved in handling the current request." } ; - -HELP: client-state -{ $values { "key" string } { "value/f" { $maybe string } } } -{ $description "Looks up a cookie (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." } -{ $notes "This word is used by session management, conversation scope and asides." } ; - -HELP: each-responder -{ $values { "quot" { $quotation "( responder -- )" } } } -{ $description "Applies the quotation to each responder involved in processing the current request." } ; - -HELP: hidden-form-field -{ $values { "value" string } { "name" string } } -{ $description "Renders an HTML hidden form field tag." } -{ $notes "This word is used by session management, conversation scope and asides." } -{ $examples - { $example - "USING: furnace io ;" - "\"bar\" \"foo\" hidden-form-field nl" - "" - } -} ; - -HELP: link-attr -{ $values { "tag" tag } { "responder" "a responder" } } -{ $contract "Modifies an XHTML " { $snippet "a" } " tag." } -{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } -{ $examples "Conversation scope adds attributes to link tags." } ; - -HELP: modify-form -{ $values { "responder" "a responder" } } -{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." } -{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } -{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ; - -HELP: modify-query -{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } } -{ $contract "Modifies the query parameters of a URL destined to be displayed as a link." } -{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } -{ $examples "Asides add query parameters to URLs." } ; - -HELP: modify-redirect-query -{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } } -{ $contract "Modifies the query parameters of a URL destined to be used with a redirect." } -{ $notes "This word is called by " { $link "furnace.redirection" } "." } -{ $examples "Conversation scope and asides add query parameters to redirect URLs." } ; - -HELP: nested-responders -{ $values { "seq" "a sequence of responders" } } -{ $description "" } ; - -HELP: referrer -{ $values { "referrer/f" { $maybe string } } } -{ $description "Outputs the current request's referrer URL." } ; - -HELP: request-params -{ $values { "request" request } { "assoc" assoc } } -{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ; - -HELP: resolve-base-path -{ $values { "string" string } { "string'" string } } -{ $description "" } ; - -HELP: resolve-template-path -{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } } -{ $description "" } ; - -HELP: same-host? -{ $values { "url" url } { "?" "a boolean" } } -{ $description "Tests if the given URL is located on the same host as the URL of the current request." } ; - -HELP: user-agent -{ $values { "user-agent" { $maybe string } } } -{ $description "Outputs the user agent reported by the client for the current request." } ; - -HELP: vocab-path -{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } } -{ $description "" } ; - -HELP: exit-with -{ $values { "value" object } } -{ $description "Exits from an outer " { $link with-exit-continuation } "." } ; - -HELP: with-exit-continuation -{ $values { "quot" { $quotation { "( -- value )" } } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } } -{ $description "Runs a quotation with the " { $link exit-continuation } " variable bound. Calling " { $link exit-with } " in the quotation will immediately return." } -{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ; - -ARTICLE: "furnace.extension-points" "Furnace extension points" -"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used." -$nl -"Responders can implement methods on the following generic words:" -{ $subsection modify-query } -{ $subsection modify-redirect-query } -{ $subsection link-attr } -{ $subsection modify-form } -"Presentation-level code can call the following words:" -{ $subsection adjust-url } -{ $subsection adjust-redirect-url } ; - -ARTICLE: "furnace.misc" "Miscellaneous Furnace features" -"Inspecting the chain of responders handling the current request:" -{ $subsection nested-responders } -{ $subsection each-responder } -{ $subsection resolve-base-path } -"Vocabulary root-relative resources:" -{ $subsection vocab-path } -{ $subsection resolve-template-path } -"Early return from a responder:" -{ $subsection with-exit-continuation } -{ $subsection exit-with } -"Other useful words:" -{ $subsection hidden-form-field } -{ $subsection request-params } -{ $subsection client-state } -{ $subsection user-agent } ; - ARTICLE: "furnace.persistence" "Furnace persistence layer" { $subsection "furnace.db" } "Server-side state:" diff --git a/basis/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor index 00e4f6f152..f6e5434997 100644 --- a/basis/furnace/furnace-tests.factor +++ b/basis/furnace/furnace-tests.factor @@ -1,7 +1,7 @@ IN: furnace.tests USING: http http.server.dispatchers http.server.responses -http.server furnace tools.test kernel namespaces accessors -io.streams.string urls ; +http.server furnace furnace.utilities tools.test kernel +namespaces accessors io.streams.string urls ; TUPLE: funny-dispatcher < dispatcher ; : funny-dispatcher new-dispatcher ; diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor index 29eb00a8f4..adafb21524 100644 --- a/basis/furnace/furnace.factor +++ b/basis/furnace/furnace.factor @@ -1,133 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces make assocs sequences kernel classes splitting -vocabs.loader accessors strings combinators arrays -continuations present fry -urls html.elements -http http.server http.server.redirection http.server.remapping ; IN: furnace -: nested-responders ( -- seq ) - responder-nesting get values ; - -: each-responder ( quot -- ) - nested-responders swap each ; inline - -: base-path ( string -- pair ) - dup responder-nesting get - [ second class superclasses [ name>> = ] with contains? ] with find nip - [ first ] [ "No such responder: " swap append throw ] ?if ; - -: resolve-base-path ( string -- string' ) - "$" ?head [ - [ - "/" split1 [ base-path [ "/" % % ] each "/" % ] dip % - ] "" make - ] when ; - -: vocab-path ( vocab -- path ) - dup vocab-dir vocab-append-path ; - -: resolve-template-path ( pair -- path ) - [ - first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi* - ] "" make ; - -GENERIC: modify-query ( query responder -- query' ) - -M: object modify-query drop ; - -GENERIC: modify-redirect-query ( query responder -- query' ) - -M: object modify-redirect-query drop ; - -GENERIC: adjust-url ( url -- url' ) - -M: url adjust-url - clone - [ [ modify-query ] each-responder ] change-query - [ resolve-base-path ] change-path - relative-to-request ; - -M: string adjust-url ; - -GENERIC: adjust-redirect-url ( url -- url' ) - -M: url adjust-redirect-url - adjust-url - [ [ modify-redirect-query ] each-responder ] change-query ; - -M: string adjust-redirect-url ; - -GENERIC: link-attr ( tag responder -- ) - -M: object link-attr 2drop ; - -GENERIC: modify-form ( responder -- ) - -M: object modify-form drop ; - -: hidden-form-field ( value name -- ) - over [ - - ] [ 2drop ] if ; - -: nested-forms-key "__n" ; - -: request-params ( request -- assoc ) - dup method>> { - { "GET" [ url>> query>> ] } - { "HEAD" [ url>> query>> ] } - { "POST" [ - post-data>> - dup content-type>> "application/x-www-form-urlencoded" = - [ content>> ] [ drop f ] if - ] } - } case ; - -: referrer ( -- referrer/f ) - #! Typo is intentional, it's in the HTTP spec! - "referer" request get header>> at - dup [ >url ensure-port [ remap-port ] change-port ] when ; - -: user-agent ( -- user-agent ) - "user-agent" request get header>> at "" or ; - -: same-host? ( url -- ? ) - dup [ - url get [ - [ protocol>> ] - [ host>> ] - [ port>> remap-port ] - tri 3array - ] bi@ = - ] when ; - -: cookie-client-state ( key request -- value/f ) - swap get-cookie dup [ value>> ] when ; - -: post-client-state ( key request -- value/f ) - request-params at ; - -: client-state ( key -- value/f ) - request get dup method>> { - { "GET" [ cookie-client-state ] } - { "HEAD" [ cookie-client-state ] } - { "POST" [ post-client-state ] } - } case ; - -SYMBOL: exit-continuation - -: exit-with ( value -- ) - exit-continuation get continue-with ; - -: with-exit-continuation ( quot -- value ) - '[ exit-continuation set @ ] callcc1 exit-continuation off ; - USE: vocabs.loader "furnace.actions" require "furnace.alloy" require diff --git a/basis/furnace/redirection/redirection.factor b/basis/furnace/redirection/redirection.factor index c5a63a795c..01297288dc 100644 --- a/basis/furnace/redirection/redirection.factor +++ b/basis/furnace/redirection/redirection.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors combinators namespaces fry urls http http.server http.server.redirection http.server.responses -http.server.remapping http.server.filters furnace ; +http.server.remapping http.server.filters furnace.utilities ; IN: furnace.redirection : ( url -- response ) diff --git a/basis/furnace/referrer/referrer-docs.factor b/basis/furnace/referrer/referrer-docs.factor index 599461c37c..b57bcb262b 100644 --- a/basis/furnace/referrer/referrer-docs.factor +++ b/basis/furnace/referrer/referrer-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io.streams.string -furnace ; +furnace.utilities ; IN: furnace.referrer HELP: diff --git a/basis/furnace/referrer/referrer.factor b/basis/furnace/referrer/referrer.factor index 003028ab1e..e5666c2698 100644 --- a/basis/furnace/referrer/referrer.factor +++ b/basis/furnace/referrer/referrer.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel http.server http.server.filters -http.server.responses furnace ; +http.server.responses furnace.utilities ; IN: furnace.referrer TUPLE: referrer-check < filter-responder quot ; diff --git a/basis/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor index 6bb3c1cd69..907e657125 100644 --- a/basis/furnace/sessions/sessions-tests.factor +++ b/basis/furnace/sessions/sessions-tests.factor @@ -3,7 +3,8 @@ USING: tools.test http furnace.sessions furnace.actions http.server http.server.responses math namespaces make kernel accessors io.sockets io.servers.connection prettyprint io.streams.string io.files splitting destructors sequences db -db.tuples db.sqlite continuations urls math.parser furnace ; +db.tuples db.sqlite continuations urls math.parser furnace +furnace.utilities ; : with-session [ diff --git a/basis/furnace/sessions/sessions.factor b/basis/furnace/sessions/sessions.factor index b7120aaf11..cde95f2831 100644 --- a/basis/furnace/sessions/sessions.factor +++ b/basis/furnace/sessions/sessions.factor @@ -1,13 +1,11 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel math.intervals math.parser namespaces -strings random accessors quotations hashtables sequences continuations -fry calendar combinators combinators.short-circuit destructors alarms -io.servers.connection -db db.tuples db.types +strings random accessors quotations hashtables sequences +continuations fry calendar combinators combinators.short-circuit +destructors alarms io.servers.connection db db.tuples db.types http http.server http.server.dispatchers http.server.filters -html.elements -furnace furnace.cache furnace.scopes ; +html.elements furnace.cache furnace.scopes furnace.utilities ; IN: furnace.sessions TUPLE: session < scope user-agent client ; diff --git a/basis/furnace/syndication/syndication.factor b/basis/furnace/syndication/syndication.factor index a326e62f02..876aaf8c98 100644 --- a/basis/furnace/syndication/syndication.factor +++ b/basis/furnace/syndication/syndication.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences fry -combinators syndication -http.server.responses http.server.redirection -furnace furnace.actions ; +USING: accessors kernel sequences fry combinators syndication +http.server.responses http.server.redirection furnace.actions +furnace.utilities ; IN: furnace.syndication GENERIC: feed-entry-title ( object -- string ) diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor new file mode 100644 index 0000000000..1402e9c0ca --- /dev/null +++ b/basis/furnace/utilities/utilities-docs.factor @@ -0,0 +1,126 @@ +USING: assocs help.markup help.syntax kernel +quotations sequences strings urls xml.data http ; +IN: furnace.utilities + +HELP: adjust-redirect-url +{ $values { "url" url } { "url'" url } } +{ $description "Adjusts a redirection URL by filtering the URL's query parameters through the " { $link modify-redirect-query } " generic word on every responder involved in handling the current request." } ; + +HELP: adjust-url +{ $values { "url" url } { "url'" url } } +{ $description "Adjusts a link URL by filtering the URL's query parameters through the " { $link modify-query } " generic word on every responder involved in handling the current request." } ; + +HELP: client-state +{ $values { "key" string } { "value/f" { $maybe string } } } +{ $description "Looks up a cookie (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." } +{ $notes "This word is used by session management, conversation scope and asides." } ; + +HELP: each-responder +{ $values { "quot" { $quotation "( responder -- )" } } } +{ $description "Applies the quotation to each responder involved in processing the current request." } ; + +HELP: hidden-form-field +{ $values { "value" string } { "name" string } } +{ $description "Renders an HTML hidden form field tag." } +{ $notes "This word is used by session management, conversation scope and asides." } +{ $examples + { $example + "USING: furnace.utilities io ;" + "\"bar\" \"foo\" hidden-form-field nl" + "" + } +} ; + +HELP: link-attr +{ $values { "tag" tag } { "responder" "a responder" } } +{ $contract "Modifies an XHTML " { $snippet "a" } " tag." } +{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } +{ $examples "Conversation scope adds attributes to link tags." } ; + +HELP: modify-form +{ $values { "responder" "a responder" } } +{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." } +{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } +{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ; + +HELP: modify-query +{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } } +{ $contract "Modifies the query parameters of a URL destined to be displayed as a link." } +{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } +{ $examples "Asides add query parameters to URLs." } ; + +HELP: modify-redirect-query +{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } } +{ $contract "Modifies the query parameters of a URL destined to be used with a redirect." } +{ $notes "This word is called by " { $link "furnace.redirection" } "." } +{ $examples "Conversation scope and asides add query parameters to redirect URLs." } ; + +HELP: nested-responders +{ $values { "seq" "a sequence of responders" } } +{ $description "" } ; + +HELP: referrer +{ $values { "referrer/f" { $maybe string } } } +{ $description "Outputs the current request's referrer URL." } ; + +HELP: request-params +{ $values { "request" request } { "assoc" assoc } } +{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ; + +HELP: resolve-base-path +{ $values { "string" string } { "string'" string } } +{ $description "" } ; + +HELP: resolve-template-path +{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } } +{ $description "" } ; + +HELP: same-host? +{ $values { "url" url } { "?" "a boolean" } } +{ $description "Tests if the given URL is located on the same host as the URL of the current request." } ; + +HELP: user-agent +{ $values { "user-agent" { $maybe string } } } +{ $description "Outputs the user agent reported by the client for the current request." } ; + +HELP: vocab-path +{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } } +{ $description "" } ; + +HELP: exit-with +{ $values { "value" object } } +{ $description "Exits from an outer " { $link with-exit-continuation } "." } ; + +HELP: with-exit-continuation +{ $values { "quot" { $quotation { "( -- value )" } } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } } +{ $description "Runs a quotation with the " { $link exit-continuation } " variable bound. Calling " { $link exit-with } " in the quotation will immediately return." } +{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ; + +ARTICLE: "furnace.extension-points" "Furnace extension points" +"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used." +$nl +"Responders can implement methods on the following generic words:" +{ $subsection modify-query } +{ $subsection modify-redirect-query } +{ $subsection link-attr } +{ $subsection modify-form } +"Presentation-level code can call the following words:" +{ $subsection adjust-url } +{ $subsection adjust-redirect-url } ; + +ARTICLE: "furnace.misc" "Miscellaneous Furnace features" +"Inspecting the chain of responders handling the current request:" +{ $subsection nested-responders } +{ $subsection each-responder } +{ $subsection resolve-base-path } +"Vocabulary root-relative resources:" +{ $subsection vocab-path } +{ $subsection resolve-template-path } +"Early return from a responder:" +{ $subsection with-exit-continuation } +{ $subsection exit-with } +"Other useful words:" +{ $subsection hidden-form-field } +{ $subsection request-params } +{ $subsection client-state } +{ $subsection user-agent } ; diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index 4bfbdcd943..f2b71fb89f 100644 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -1,6 +1,9 @@ -! Copyright (c) 2008 Slava Pestov +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors words kernel sequences splitting ; +USING: namespaces make assocs sequences kernel classes splitting +words vocabs.loader accessors strings combinators arrays +continuations present fry urls html.elements http http.server +http.server.redirection http.server.remapping ; IN: furnace.utilities : word>string ( word -- string ) @@ -17,3 +20,124 @@ ERROR: no-such-word name vocab ; : strings>words ( seq -- seq' ) [ string>word ] map ; + +: nested-responders ( -- seq ) + responder-nesting get values ; + +: each-responder ( quot -- ) + nested-responders swap each ; inline + +: base-path ( string -- pair ) + dup responder-nesting get + [ second class superclasses [ name>> = ] with contains? ] with find nip + [ first ] [ "No such responder: " swap append throw ] ?if ; + +: resolve-base-path ( string -- string' ) + "$" ?head [ + [ + "/" split1 [ base-path [ "/" % % ] each "/" % ] dip % + ] "" make + ] when ; + +: vocab-path ( vocab -- path ) + dup vocab-dir vocab-append-path ; + +: resolve-template-path ( pair -- path ) + [ + first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi* + ] "" make ; + +GENERIC: modify-query ( query responder -- query' ) + +M: object modify-query drop ; + +GENERIC: modify-redirect-query ( query responder -- query' ) + +M: object modify-redirect-query drop ; + +GENERIC: adjust-url ( url -- url' ) + +M: url adjust-url + clone + [ [ modify-query ] each-responder ] change-query + [ resolve-base-path ] change-path + relative-to-request ; + +M: string adjust-url ; + +GENERIC: adjust-redirect-url ( url -- url' ) + +M: url adjust-redirect-url + adjust-url + [ [ modify-redirect-query ] each-responder ] change-query ; + +M: string adjust-redirect-url ; + +GENERIC: link-attr ( tag responder -- ) + +M: object link-attr 2drop ; + +GENERIC: modify-form ( responder -- ) + +M: object modify-form drop ; + +: hidden-form-field ( value name -- ) + over [ + + ] [ 2drop ] if ; + +: nested-forms-key "__n" ; + +: request-params ( request -- assoc ) + dup method>> { + { "GET" [ url>> query>> ] } + { "HEAD" [ url>> query>> ] } + { "POST" [ + post-data>> + dup content-type>> "application/x-www-form-urlencoded" = + [ content>> ] [ drop f ] if + ] } + } case ; + +: referrer ( -- referrer/f ) + #! Typo is intentional, it's in the HTTP spec! + "referer" request get header>> at + dup [ >url ensure-port [ remap-port ] change-port ] when ; + +: user-agent ( -- user-agent ) + "user-agent" request get header>> at "" or ; + +: same-host? ( url -- ? ) + dup [ + url get [ + [ protocol>> ] + [ host>> ] + [ port>> remap-port ] + tri 3array + ] bi@ = + ] when ; + +: cookie-client-state ( key request -- value/f ) + swap get-cookie dup [ value>> ] when ; + +: post-client-state ( key request -- value/f ) + request-params at ; + +: client-state ( key -- value/f ) + request get dup method>> { + { "GET" [ cookie-client-state ] } + { "HEAD" [ cookie-client-state ] } + { "POST" [ post-client-state ] } + } case ; + +SYMBOL: exit-continuation + +: exit-with ( value -- ) + exit-continuation get continue-with ; + +: with-exit-continuation ( quot -- value ) + '[ exit-continuation set @ ] callcc1 exit-continuation off ; diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index b833cc8cc2..b78dc25d79 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -7,8 +7,8 @@ syndication farkup html.components html.forms http.server http.server.dispatchers -furnace furnace.actions +furnace.utilities furnace.redirection furnace.auth furnace.auth.login From 6297c4d2e4879faedb1144b9bf1d020d8dc0fcda Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 24 Nov 2008 20:26:29 -0600 Subject: [PATCH 08/30] Make cookie parsing more permissive --- basis/http/http-tests.factor | 9 ++++++++- basis/http/parsers/parsers.factor | 14 ++++++++------ 2 files changed, 16 insertions(+), 7 deletions(-) diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 96320b7d12..6e93d5ee3a 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -2,7 +2,7 @@ USING: http http.server http.client tools.test multiline io.streams.string io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.encodings.string kernel arrays splitting sequences assocs io.sockets db db.sqlite continuations urls -hashtables accessors ; +hashtables accessors namespaces ; IN: http.tests [ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test @@ -11,6 +11,12 @@ IN: http.tests [ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test +[ { } ] [ "" parse-cookie ] unit-test +[ { } ] [ "" parse-set-cookie ] unit-test + +! Make sure that totally invalid cookies don't confuse us +[ { } ] [ "hello world; how are you" parse-cookie ] unit-test + : lf>crlf "\n" split "\r\n" join ; STRING: read-request-test-1 @@ -126,6 +132,7 @@ content-type: text/html; charset=UTF-8 ; read-response-test-1' 1array [ + URL" http://localhost/" url set read-response-test-1 lf>crlf [ read-response ] with-string-reader [ write-response ] with-string-writer diff --git a/basis/http/parsers/parsers.factor b/basis/http/parsers/parsers.factor index 8e8e7358d1..d72147b381 100644 --- a/basis/http/parsers/parsers.factor +++ b/basis/http/parsers/parsers.factor @@ -142,16 +142,15 @@ PEG: parse-header-line ( string -- pair ) 'space' , 'attr' , 'space' , - [ "=" token , 'space' , 'value' , ] seq* [ peek ] action - epsilon [ drop f ] action - 2choice , + [ "=" token , 'space' , 'value' , ] seq* [ peek ] action optional , 'space' , ] seq* ; : 'av-pairs' ( -- parser ) 'av-pair' ";" token list-of optional ; -PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ; +PEG: (parse-set-cookie) ( string -- alist ) + 'av-pairs' just [ sift ] action ; : 'cookie-value' ( -- parser ) [ @@ -162,7 +161,10 @@ PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ; 'space' , 'value' , 'space' , - ] seq* ; + ] seq* + [ ";,=" member? not ] satisfy repeat1 [ drop f ] action + 2choice ; PEG: (parse-cookie) ( string -- alist ) - 'cookie-value' [ ";," member? ] satisfy list-of optional just ; + 'cookie-value' [ ";," member? ] satisfy list-of + optional just [ sift ] action ; From 37f991420b8242ac0516c8533ae0d205556f1a03 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 24 Nov 2008 22:01:33 -0600 Subject: [PATCH 09/30] fix load error --- extra/webapps/wee-url/wee-url.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor index e4a4a6a853..af7c8b61ce 100644 --- a/extra/webapps/wee-url/wee-url.factor +++ b/extra/webapps/wee-url/wee-url.factor @@ -4,7 +4,8 @@ USING: math.ranges sequences random accessors combinators.lib kernel namespaces fry db.types db.tuples urls validators html.components html.forms http http.server.dispatchers furnace -furnace.actions furnace.boilerplate furnace.redirection ; +furnace.actions furnace.boilerplate furnace.redirection +furnace.utilities ; IN: webapps.wee-url TUPLE: wee-url < dispatcher ; From 1f61f6dad0bcf1d0ac52a5c7d19d9cf22ec58b2e Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 25 Nov 2008 11:48:11 +0100 Subject: [PATCH 10/30] Emacs factor modes: gensym is not needed. --- misc/factor.el | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index 6c9faf50c9..790ff0c56a 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -652,13 +652,12 @@ vocabularies which have been modified on disk." ;;; Key bindings: -(defmacro factor--define-key (key cmd &optional both) - (let ((m (gensym)) - (ms '(factor-mode-map))) - (when both (push 'factor-help-mode-map ms)) - `(dolist (,m (list ,@ms)) - (define-key ,m [(control ?c) ,key] ,cmd) - (define-key ,m [(control ?c) (control ,key)] ,cmd)))) +(defun factor--define-key (key cmd &optional both) + (let ((ms (list factor-mode-map))) + (when both (push factor-help-mode-map ms)) + (dolist (m ms) + (define-key m (vector '(control ?c) key) cmd) + (define-key m (vector '(control ?c) `(control ,key)) cmd)))) (factor--define-key ?f 'factor-run-file) (factor--define-key ?r 'factor-send-region) From de957735744620132c63e3291ce2f96d2a507ab5 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 25 Nov 2008 05:55:49 -0600 Subject: [PATCH 11/30] generalizations: Update 'npick' to not use >r and r> --- basis/generalizations/generalizations.factor | 141 ++++++++++--------- 1 file changed, 73 insertions(+), 68 deletions(-) diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index c63c2b66ca..74291bae33 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -1,68 +1,73 @@ -! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo -! Cavazos, Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences sequences.private namespaces math -math.ranges combinators macros quotations fry arrays ; -IN: generalizations - -MACRO: nsequence ( n seq -- quot ) - [ - [ drop ] [ '[ _ _ new-sequence ] ] 2bi - [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce - ] keep - '[ @ _ like ] ; - -MACRO: narray ( n -- quot ) - '[ _ { } nsequence ] ; - -MACRO: firstn ( n -- ) - dup zero? [ drop [ drop ] ] [ - [ [ '[ [ _ ] dip nth-unsafe ] ] map ] - [ 1- '[ [ _ ] dip bounds-check 2drop ] ] - bi prefix '[ _ cleave ] - ] if ; - -MACRO: npick ( n -- ) - 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ; - -MACRO: ndup ( n -- ) - dup '[ _ npick ] n*quot ; - -MACRO: nrot ( n -- ) - 1- dup saver swap [ r> swap ] n*quot append ; - -MACRO: -nrot ( n -- ) - 1- dup [ swap >r ] n*quot swap restorer append ; - -MACRO: ndrop ( n -- ) - [ drop ] n*quot ; - -: nnip ( n -- ) - swap >r ndrop r> ; inline - -MACRO: ntuck ( n -- ) - 2 + [ dupd -nrot ] curry ; - -MACRO: nrev ( n -- quot ) - 1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ; - -MACRO: ndip ( quot n -- ) - dup saver -rot restorer 3append ; - -MACRO: nslip ( n -- ) - dup saver [ call ] rot restorer 3append ; - -MACRO: nkeep ( n -- ) - [ ] [ 1+ ] [ ] tri - '[ [ _ ndup ] dip _ -nrot _ nslip ] ; - -MACRO: ncurry ( n -- ) - [ curry ] n*quot ; - -MACRO: nwith ( n -- ) - [ with ] n*quot ; - -MACRO: napply ( n -- ) - 2 [a,b] - [ [ 1- ] keep '[ _ ntuck _ nslip ] ] - map concat >quotation [ call ] append ; +! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo +! Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences sequences.private namespaces math +math.ranges combinators macros quotations fry arrays ; +IN: generalizations + +MACRO: nsequence ( n seq -- quot ) + [ + [ drop ] [ '[ _ _ new-sequence ] ] 2bi + [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce + ] keep + '[ @ _ like ] ; + +MACRO: narray ( n -- quot ) + '[ _ { } nsequence ] ; + +MACRO: firstn ( n -- ) + dup zero? [ drop [ drop ] ] [ + [ [ '[ [ _ ] dip nth-unsafe ] ] map ] + [ 1- '[ [ _ ] dip bounds-check 2drop ] ] + bi prefix '[ _ cleave ] + ] if ; + +: npick-wrap ( quot n -- quot ) + dup 1 > + [ swap '[ _ dip swap ] swap 1 - npick-wrap ] + [ drop ] + if ; + +MACRO: npick ( n -- quot ) [ dup ] swap npick-wrap ; + +MACRO: ndup ( n -- ) + dup '[ _ npick ] n*quot ; + +MACRO: nrot ( n -- ) + 1- dup saver swap [ r> swap ] n*quot append ; + +MACRO: -nrot ( n -- ) + 1- dup [ swap >r ] n*quot swap restorer append ; + +MACRO: ndrop ( n -- ) + [ drop ] n*quot ; + +: nnip ( n -- ) + swap >r ndrop r> ; inline + +MACRO: ntuck ( n -- ) + 2 + [ dupd -nrot ] curry ; + +MACRO: nrev ( n -- quot ) + 1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ; + +MACRO: ndip ( quot n -- ) + dup saver -rot restorer 3append ; + +MACRO: nslip ( n -- ) + dup saver [ call ] rot restorer 3append ; + +MACRO: nkeep ( n -- ) + [ ] [ 1+ ] [ ] tri + '[ [ _ ndup ] dip _ -nrot _ nslip ] ; + +MACRO: ncurry ( n -- ) + [ curry ] n*quot ; + +MACRO: nwith ( n -- ) + [ with ] n*quot ; + +MACRO: napply ( n -- ) + 2 [a,b] + [ [ 1- ] keep '[ _ ntuck _ nslip ] ] + map concat >quotation [ call ] append ; From a11453e458d5e94e0ef04ff8528baf1dbf4acc79 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Tue, 25 Nov 2008 21:53:06 +0100 Subject: [PATCH 12/30] Emacs factor-mode: fix indentation of empty line after starting word definition. --- misc/factor.el | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/misc/factor.el b/misc/factor.el index 790ff0c56a..346642f70c 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -160,10 +160,6 @@ buffer." ;;; Factor mode font lock: -(defconst factor--regexp-word-start - (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))) - (format "^\\(%s\\)\\(:\\) " (mapconcat 'identity sws "\\|")))) - (defconst factor--parsing-words '("{" "}" "^:" "^::" ";" "<<" ">" "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{" @@ -222,6 +218,10 @@ buffer." ;;; Factor mode syntax: +(defconst factor--regexp-word-start + (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))) + (format "^\\(%s\\)\\(:\\) " (regexp-opt sws)))) + (defconst factor--font-lock-syntactic-keywords `(("^\\(:\\)\\(:\\)" (1 ".") (2 "(;")) (,factor--regexp-word-start (2 "(;")) @@ -321,7 +321,7 @@ buffer." "PRIVATE>" " Date: Tue, 25 Nov 2008 16:26:17 -0600 Subject: [PATCH 13/30] Clean up --- basis/ui/gadgets/canvas/canvas.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/ui/gadgets/canvas/canvas.factor b/basis/ui/gadgets/canvas/canvas.factor index 4ff7519a85..0028b9b165 100644 --- a/basis/ui/gadgets/canvas/canvas.factor +++ b/basis/ui/gadgets/canvas/canvas.factor @@ -12,8 +12,7 @@ TUPLE: canvas < gadget dlist ; : delete-canvas-dlist ( canvas -- ) [ find-gl-context ] - [ dlist>> [ delete-dlist ] when* ] - [ f >>dlist drop ] tri ; + [ [ [ delete-dlist ] when* f ] change-dlist drop ] bi ; : make-canvas-dlist ( canvas quot -- dlist ) [ drop ] [ GL_COMPILE swap make-dlist ] 2bi From 30f93f547f8e2eaeee912842b3e884f6234d69e1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Nov 2008 16:47:47 -0600 Subject: [PATCH 14/30] generalizations and delegate no longer uses >r/r> --- basis/delegate/delegate.factor | 12 +----- basis/generalizations/generalizations.factor | 42 ++++++++++---------- 2 files changed, 24 insertions(+), 30 deletions(-) diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index 12860337ff..3a7cecb800 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors parser generic kernel classes classes.tuple words slots assocs sequences arrays vectors definitions -prettyprint math hashtables sets macros namespaces make ; +prettyprint math hashtables sets generalizations namespaces make ; IN: delegate : protocol-words ( protocol -- words ) @@ -25,15 +25,7 @@ M: tuple-class group-words : consult-method ( word class quot -- ) [ drop swap first create-method ] - [ - nip - [ - over second saver % - % - dup second restorer % - first , - ] [ ] make - ] 3bi + [ nip [ , dup second , \ ndip , first , ] [ ] make ] 3bi define ; : change-word-prop ( word prop quot -- ) diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 74291bae33..490fa77204 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -1,10 +1,18 @@ ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo ! Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences sequences.private namespaces math -math.ranges combinators macros quotations fry arrays ; +USING: kernel sequences sequences.private math math.ranges +combinators macros quotations fry ; IN: generalizations +<< + +: n*quot ( n seq -- seq' ) concat >quotation ; + +: repeat ( n obj quot -- ) swapd times ; inline + +>> + MACRO: nsequence ( n seq -- quot ) [ [ drop ] [ '[ _ _ new-sequence ] ] 2bi @@ -22,44 +30,38 @@ MACRO: firstn ( n -- ) bi prefix '[ _ cleave ] ] if ; -: npick-wrap ( quot n -- quot ) - dup 1 > - [ swap '[ _ dip swap ] swap 1 - npick-wrap ] - [ drop ] - if ; - -MACRO: npick ( n -- quot ) [ dup ] swap npick-wrap ; +MACRO: npick ( n -- quot ) + 1- [ dup ] [ '[ _ dip swap ] ] repeat ; MACRO: ndup ( n -- ) dup '[ _ npick ] n*quot ; MACRO: nrot ( n -- ) - 1- dup saver swap [ r> swap ] n*quot append ; + 1- [ ] [ '[ _ dip swap ] ] repeat ; MACRO: -nrot ( n -- ) - 1- dup [ swap >r ] n*quot swap restorer append ; + 1- [ ] [ '[ swap _ dip ] ] repeat ; MACRO: ndrop ( n -- ) [ drop ] n*quot ; -: nnip ( n -- ) - swap >r ndrop r> ; inline +MACRO: nnip ( n -- ) + '[ [ _ ndrop ] dip ] ; MACRO: ntuck ( n -- ) - 2 + [ dupd -nrot ] curry ; + 2 + '[ dup _ -nrot ] ; MACRO: nrev ( n -- quot ) 1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ; MACRO: ndip ( quot n -- ) - dup saver -rot restorer 3append ; + [ '[ _ dip ] ] times ; MACRO: nslip ( n -- ) - dup saver [ call ] rot restorer 3append ; + '[ [ call ] _ ndip ] ; -MACRO: nkeep ( n -- ) - [ ] [ 1+ ] [ ] tri - '[ [ _ ndup ] dip _ -nrot _ nslip ] ; +MACRO: nkeep ( quot n -- ) + tuck '[ _ ndup _ _ ndip ] ; MACRO: ncurry ( n -- ) [ curry ] n*quot ; @@ -69,5 +71,5 @@ MACRO: nwith ( n -- ) MACRO: napply ( n -- ) 2 [a,b] - [ [ 1- ] keep '[ _ ntuck _ nslip ] ] + [ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ] map concat >quotation [ call ] append ; From f3f3b3e76966afa8d7e1a9807eddfeab26e04cc3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Nov 2008 16:47:56 -0600 Subject: [PATCH 15/30] Remove some unused words --- basis/macros/macros.factor | 6 ------ 1 file changed, 6 deletions(-) diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 794d523d00..1481e6eea5 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -22,9 +22,3 @@ M: macro definition "macro" word-prop ; M: macro reset-word [ call-next-method ] [ f "macro" set-word-prop ] bi ; - -: n*quot ( n seq -- seq' ) concat >quotation ; - -: saver ( n -- quot ) \ >r >quotation ; - -: restorer ( n -- quot ) \ r> >quotation ; From 2f025f58ae2b8796aed0f4beaf8b50e7b288a1f0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 25 Nov 2008 19:20:25 -0600 Subject: [PATCH 16/30] Frames had problems with resizing --- basis/ui/gadgets/frames/frames-tests.factor | 15 +++++++++++++- basis/ui/gadgets/frames/frames.factor | 22 ++++++++++++--------- 2 files changed, 27 insertions(+), 10 deletions(-) diff --git a/basis/ui/gadgets/frames/frames-tests.factor b/basis/ui/gadgets/frames/frames-tests.factor index e38e97c76c..27d511e10a 100644 --- a/basis/ui/gadgets/frames/frames-tests.factor +++ b/basis/ui/gadgets/frames/frames-tests.factor @@ -1,4 +1,17 @@ +USING: accessors kernel namespaces tools.test ui.gadgets +ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels ; IN: ui.gadgets.frames.tests -USING: ui.gadgets.frames ui.gadgets tools.test ; [ ] [ layout ] unit-test + +[ t ] [ + + "Hello world"