Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
984a010df0
|
|
@ -1,7 +1,7 @@
|
|||
IN: io.streams.limited.tests
|
||||
USING: io io.streams.limited io.encodings io.encodings.string
|
||||
io.encodings.ascii io.encodings.binary io.streams.byte-array
|
||||
namespaces tools.test strings kernel ;
|
||||
namespaces tools.test strings kernel io.streams.string accessors ;
|
||||
IN: io.streams.limited.tests
|
||||
|
||||
[ ] [
|
||||
"hello world\nhow are you today\nthis is a very long line indeed"
|
||||
|
|
@ -38,3 +38,18 @@ namespaces tools.test strings kernel ;
|
|||
"l" read-until
|
||||
] with-input-stream
|
||||
] unit-test
|
||||
|
||||
[ CHAR: a ]
|
||||
[ "a" <string-reader> 1 <limited-stream> stream-read1 ] unit-test
|
||||
|
||||
[ "abc" ]
|
||||
[
|
||||
"abc" <string-reader> 3 <limited-stream> t >>no-throw?
|
||||
4 swap stream-read
|
||||
] unit-test
|
||||
|
||||
[ f ]
|
||||
[
|
||||
"abc" <string-reader> 3 <limited-stream> t >>no-throw?
|
||||
4 over stream-read drop 10 swap stream-read
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math io io.encodings destructors accessors
|
||||
sequences namespaces byte-vectors ;
|
||||
sequences namespaces byte-vectors fry ;
|
||||
IN: io.streams.limited
|
||||
|
||||
TUPLE: limited-stream stream count limit ;
|
||||
TUPLE: limited-stream stream count limit no-throw? ;
|
||||
|
||||
: <limited-stream> ( stream limit -- stream' )
|
||||
limited-stream new
|
||||
|
|
@ -22,19 +22,30 @@ M: object limit <limited-stream> ;
|
|||
|
||||
ERROR: limit-exceeded ;
|
||||
|
||||
: check-limit ( n stream -- )
|
||||
[ + ] change-count
|
||||
[ count>> ] [ limit>> ] bi >=
|
||||
[ limit-exceeded ] when ; inline
|
||||
: adjust-limit ( n stream -- n' stream )
|
||||
2dup [ + ] change-count
|
||||
[ count>> ] [ limit>> ] bi >
|
||||
[
|
||||
dup no-throw?>> [
|
||||
dup [ count>> ] [ limit>> ] bi -
|
||||
'[ _ - ] dip
|
||||
] [
|
||||
limit-exceeded
|
||||
] if
|
||||
] when ; inline
|
||||
|
||||
: maybe-read ( n limited-stream quot: ( n stream -- seq/f ) -- seq/f )
|
||||
pick 0 <= [ 3drop f ] [ [ stream>> ] dip call ] if ; inline
|
||||
|
||||
M: limited-stream stream-read1
|
||||
1 over check-limit stream>> stream-read1 ;
|
||||
1 swap adjust-limit
|
||||
[ nip stream-read1 ] maybe-read ;
|
||||
|
||||
M: limited-stream stream-read
|
||||
2dup check-limit stream>> stream-read ;
|
||||
adjust-limit [ stream-read ] maybe-read ;
|
||||
|
||||
M: limited-stream stream-read-partial
|
||||
2dup check-limit stream>> stream-read-partial ;
|
||||
adjust-limit [ stream-read-partial ] maybe-read ;
|
||||
|
||||
: (read-until) ( stream seps buf -- stream seps buf sep/f )
|
||||
3dup [ [ stream-read1 dup ] dip memq? ] dip
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,105 +1,164 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators io kernel locals math multiline
|
||||
sequences splitting prettyprint namespaces http.parsers
|
||||
ascii assocs unicode.case io.files.unique io.files io.encodings.binary
|
||||
byte-arrays io.encodings make fry ;
|
||||
USING: multiline kernel sequences io splitting fry namespaces
|
||||
http.parsers hashtables assocs combinators ascii io.files.unique
|
||||
accessors io.encodings.binary io.files byte-arrays math
|
||||
io.streams.string combinators.short-circuit strings ;
|
||||
IN: mime.multipart
|
||||
|
||||
TUPLE: multipart-stream stream n leftover separator ;
|
||||
CONSTANT: buffer-size 65536
|
||||
CONSTANT: separator-prefix "\r\n--"
|
||||
|
||||
: <multipart-stream> ( stream separator -- multipart-stream )
|
||||
multipart-stream new
|
||||
swap >>separator
|
||||
swap >>stream
|
||||
16 2^ >>n ;
|
||||
TUPLE: multipart
|
||||
end-of-stream?
|
||||
current-separator mime-separator
|
||||
header
|
||||
content-disposition bytes
|
||||
filename temp-file
|
||||
name name-content
|
||||
uploaded-files
|
||||
form-variables ;
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: mime-file headers filename temporary-path ;
|
||||
TUPLE: mime-variable headers key value ;
|
||||
|
||||
: ?append ( seq1 seq2 -- newseq/seq2 )
|
||||
over [ append ] [ nip ] if ;
|
||||
: <multipart> ( mime-separator -- multipart )
|
||||
multipart new
|
||||
swap >>mime-separator
|
||||
H{ } clone >>uploaded-files
|
||||
H{ } clone >>form-variables ;
|
||||
|
||||
: ?cut* ( seq n -- before after )
|
||||
over length over <= [ drop f swap ] [ cut* ] if ;
|
||||
|
||||
: read-n ( stream -- bytes end-stream? )
|
||||
[ f ] change-leftover
|
||||
[ n>> ] [ stream>> ] bi stream-read [ ?append ] keep not ;
|
||||
ERROR: bad-header bytes ;
|
||||
|
||||
: multipart-split ( bytes separator -- before after seq=? )
|
||||
2dup sequence= [ 2drop f f t ] [ split1 f ] if ;
|
||||
: mime-write ( sequence -- )
|
||||
>byte-array write ;
|
||||
|
||||
:: multipart-step-found ( bytes stream quot: ( bytes -- ) -- ? )
|
||||
bytes [ quot unless-empty ]
|
||||
[ stream (>>leftover) quot unless-empty ] if-empty f ; inline
|
||||
: parse-headers ( string -- sequence )
|
||||
string-lines harvest [ parse-header-line ] map ;
|
||||
|
||||
:: multipart-step-not-found ( bytes stream end-stream? separator quot: ( bytes -- ) -- ? )
|
||||
bytes end-stream? [
|
||||
quot unless-empty f
|
||||
ERROR: end-of-stream multipart ;
|
||||
|
||||
: fill-bytes ( multipart -- multipart )
|
||||
buffer-size read
|
||||
[ '[ _ append ] change-bytes ]
|
||||
[ t >>end-of-stream? ] if* ;
|
||||
|
||||
: maybe-fill-bytes ( multipart -- multipart )
|
||||
dup bytes>> [ fill-bytes ] unless ;
|
||||
|
||||
: split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
|
||||
2dup [ length ] [ length 1- ] bi* < [
|
||||
drop f
|
||||
] [
|
||||
separator length 1- ?cut* stream (>>leftover)
|
||||
quot unless-empty t
|
||||
] if ; inline
|
||||
|
||||
:: multipart-step ( stream bytes end-stream? separator quot: ( bytes -- ) -- ? end-stream? )
|
||||
#! return t to loop again
|
||||
bytes separator multipart-split
|
||||
[ 2drop f ]
|
||||
[
|
||||
[ stream quot multipart-step-found ]
|
||||
[ stream end-stream? separator quot multipart-step-not-found ] if*
|
||||
] if stream leftover>> end-stream? not or >boolean ;
|
||||
|
||||
|
||||
:: multipart-step-loop ( stream quot1: ( bytes -- ) -- ? )
|
||||
stream dup [ read-n ] [ separator>> ] bi quot1 multipart-step
|
||||
swap [ drop stream quot1 multipart-step-loop ] when ; inline recursive
|
||||
|
||||
SYMBOL: header
|
||||
SYMBOL: parsed-header
|
||||
SYMBOL: magic-separator
|
||||
|
||||
: trim-blanks ( str -- str' ) [ blank? ] trim ;
|
||||
|
||||
: trim-quotes ( str -- str' )
|
||||
[ [ CHAR: " = ] [ CHAR: ' = ] bi or ] trim ;
|
||||
|
||||
: parse-content-disposition ( str -- content-disposition hash )
|
||||
";" split [ first ] [ rest-slice ] bi [ "=" split ] map
|
||||
[ [ trim-blanks ] [ trim-quotes ] bi* ] H{ } assoc-map-as ;
|
||||
|
||||
: parse-multipart-header ( string -- headers )
|
||||
"\r\n" split harvest
|
||||
[ parse-header-line first2 ] H{ } map>assoc ;
|
||||
|
||||
ERROR: expected-file ;
|
||||
|
||||
TUPLE: uploaded-file path filename name ;
|
||||
|
||||
: (parse-multipart) ( stream -- ? )
|
||||
"\r\n\r\n" >>separator
|
||||
header off
|
||||
dup [ header [ prepend ] change ] multipart-step-loop drop
|
||||
header get dup magic-separator get [ length ] bi@ < [
|
||||
2drop f
|
||||
] [
|
||||
parse-multipart-header
|
||||
parsed-header set
|
||||
"\r\n" magic-separator get append >>separator
|
||||
"factor-upload" "httpd" make-unique-file tuck
|
||||
binary [ [ write ] multipart-step-loop ] with-file-writer swap
|
||||
"content-disposition" parsed-header get at parse-content-disposition
|
||||
nip [ "filename" swap at ] [ "name" swap at ] bi
|
||||
uploaded-file boa ,
|
||||
length 1- cut-slice swap
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
: dump-until-separator ( multipart -- multipart )
|
||||
dup [ current-separator>> ] [ bytes>> ] bi tuck start [
|
||||
cut-slice
|
||||
[ mime-write ]
|
||||
[ over current-separator>> length tail-slice >>bytes ] bi*
|
||||
] [
|
||||
drop
|
||||
dup [ bytes>> ] [ current-separator>> ] bi split-bytes
|
||||
[ mime-write ] when*
|
||||
>>bytes fill-bytes dup end-of-stream?>> [ dump-until-separator ] unless
|
||||
] if* ;
|
||||
|
||||
: parse-multipart ( stream -- array )
|
||||
[
|
||||
"\r\n" <multipart-stream>
|
||||
magic-separator off
|
||||
dup [ magic-separator [ prepend ] change ]
|
||||
multipart-step-loop drop
|
||||
'[ [ _ (parse-multipart) ] loop ] { } make
|
||||
] with-scope ;
|
||||
: dump-string ( multipart separator -- multipart string )
|
||||
>>current-separator
|
||||
[ dump-until-separator ] with-string-writer ;
|
||||
|
||||
: read-header ( multipart -- multipart )
|
||||
"\r\n\r\n" dump-string dup "--\r" = [
|
||||
drop
|
||||
] [
|
||||
parse-headers >hashtable >>header
|
||||
] if ;
|
||||
|
||||
: quote? ( ch -- ? ) "'\"" member? ;
|
||||
|
||||
: quoted? ( str -- ? )
|
||||
{
|
||||
[ length 1 > ]
|
||||
[ first quote? ]
|
||||
[ [ first ] [ peek ] bi = ]
|
||||
} 1&& ;
|
||||
|
||||
: unquote ( string -- string' )
|
||||
dup quoted? [ but-last-slice rest-slice >string ] when ;
|
||||
|
||||
: save-uploaded-file ( multipart -- )
|
||||
[ unquote ] change-filename
|
||||
dup filename>> empty? [
|
||||
drop
|
||||
] [
|
||||
[ [ header>> ] [ filename>> ] [ temp-file>> ] tri mime-file boa ]
|
||||
[ filename>> ]
|
||||
[ uploaded-files>> set-at ] tri
|
||||
] if ;
|
||||
|
||||
: save-form-variable ( multipart -- )
|
||||
[ unquote ] change-name
|
||||
[ [ header>> ] [ name>> ] [ name-content>> ] tri mime-variable boa ]
|
||||
[ name>> ]
|
||||
[ form-variables>> set-at ] tri ;
|
||||
|
||||
: dump-mime-file ( multipart filename -- multipart )
|
||||
binary <file-writer> [
|
||||
dup mime-separator>> >>current-separator dump-until-separator
|
||||
] with-output-stream ;
|
||||
|
||||
: dump-file ( multipart -- multipart )
|
||||
"factor-" "-upload" make-unique-file
|
||||
[ >>temp-file ] [ dump-mime-file ] bi ;
|
||||
|
||||
: parse-content-disposition-form-data ( string -- hashtable )
|
||||
";" split
|
||||
[ "=" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ;
|
||||
|
||||
: lookup-disposition ( multipart string -- multipart value/f )
|
||||
over content-disposition>> at ;
|
||||
|
||||
ERROR: unknown-content-disposition multipart ;
|
||||
|
||||
: parse-form-data ( multipart -- multipart )
|
||||
"filename" lookup-disposition [
|
||||
>>filename
|
||||
[ dump-file ] [ save-uploaded-file ] bi
|
||||
] [
|
||||
"name" lookup-disposition [
|
||||
[ dup mime-separator>> dump-string >>name-content ] dip
|
||||
>>name dup save-form-variable
|
||||
] [
|
||||
unknown-content-disposition
|
||||
] if*
|
||||
] if* ;
|
||||
|
||||
ERROR: no-content-disposition multipart ;
|
||||
|
||||
: process-header ( multipart -- multipart )
|
||||
"content-disposition" over header>> at ";" split1 swap {
|
||||
{ "form-data" [
|
||||
parse-content-disposition-form-data >>content-disposition
|
||||
parse-form-data
|
||||
] }
|
||||
[ no-content-disposition ]
|
||||
} case ;
|
||||
|
||||
: read-assert= ( string -- )
|
||||
[ length read ] keep assert= ;
|
||||
|
||||
: parse-beginning ( multipart -- multipart )
|
||||
"--" read-assert=
|
||||
dup mime-separator>>
|
||||
[ read-assert= ]
|
||||
[ separator-prefix prepend >>mime-separator ] bi ;
|
||||
|
||||
: parse-multipart-loop ( multipart -- multipart )
|
||||
read-header
|
||||
dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
|
||||
|
||||
: parse-multipart ( sep -- uploaded-files form-variables )
|
||||
<multipart> parse-beginning parse-multipart-loop
|
||||
[ uploaded-files>> ] [ form-variables>> ] bi ;
|
||||
|
|
|
|||
|
|
@ -74,6 +74,9 @@ beast.
|
|||
|
||||
- C-cz : switch to listener
|
||||
- C-co : cycle between code, tests and docs factor files
|
||||
- C-cs : switch to other factor buffer (M-x fuel-switch-to-buffer)
|
||||
- C-x4s : switch to other factor buffer in other window
|
||||
- C-x5s : switch to other factor buffer in other frame
|
||||
|
||||
- M-. : edit word at point in Emacs (see fuel-edit-word-method custom var)
|
||||
- M-, : go back to where M-. was last invoked
|
||||
|
|
|
|||
|
|
@ -132,6 +132,32 @@ was last invoked."
|
|||
(pop-tag-mark)
|
||||
(error "No previous location for find word or vocab invokation")))
|
||||
|
||||
(defvar fuel-edit--buffer-history nil)
|
||||
|
||||
(defun fuel-switch-to-buffer (&optional method)
|
||||
"Switch to any of the existing Factor buffers, with completion."
|
||||
(interactive)
|
||||
(let ((buffer (completing-read "Factor buffer: "
|
||||
(remove (buffer-name)
|
||||
(mapcar 'buffer-name (buffer-list)))
|
||||
'(lambda (s) (string-match "\\.factor$" s))
|
||||
t
|
||||
nil
|
||||
fuel-edit--buffer-history)))
|
||||
(cond ((eq method 'window) (switch-to-buffer-other-window buffer))
|
||||
((eq method 'frame) (switch-to-buffer-other-frame buffer))
|
||||
(t (switch-to-buffer buffer)))))
|
||||
|
||||
(defun fuel-switch-to-buffer-other-window ()
|
||||
"Switch to any of the existing Factor buffers, in other window."
|
||||
(interactive)
|
||||
(fuel-switch-to-buffer 'window))
|
||||
|
||||
(defun fuel-switch-to-buffer-other-frame ()
|
||||
"Switch to any of the existing Factor buffers, in other frame."
|
||||
(interactive)
|
||||
(fuel-switch-to-buffer 'frame))
|
||||
|
||||
|
||||
(provide 'fuel-edit)
|
||||
;;; fuel-edit.el ends here
|
||||
|
|
|
|||
|
|
@ -73,18 +73,20 @@
|
|||
;;; Font lock:
|
||||
|
||||
(defun fuel-font-lock--syntactic-face (state)
|
||||
(cond ((nth 3 state) 'factor-font-lock-string)
|
||||
((char-equal (char-after (nth 8 state)) ?\ )
|
||||
(save-excursion
|
||||
(goto-char (nth 8 state))
|
||||
(beginning-of-line)
|
||||
(cond ((looking-at "USING: ") 'factor-font-lock-vocabulary-name)
|
||||
((looking-at "\\(TUPLE\\|SYMBOLS\\|VARS\\): ")
|
||||
'factor-font-lock-symbol)
|
||||
(t 'default))))
|
||||
((char-equal (char-after (nth 8 state)) ?U)
|
||||
'factor-font-lock-parsing-word)
|
||||
(t 'factor-font-lock-comment)))
|
||||
(if (nth 3 state) 'factor-font-lock-string
|
||||
(let ((c (char-after (nth 8 state))))
|
||||
(cond ((char-equal c ?\ )
|
||||
(save-excursion
|
||||
(goto-char (nth 8 state))
|
||||
(beginning-of-line)
|
||||
(cond ((looking-at "USING: ") 'factor-font-lock-vocabulary-name)
|
||||
((looking-at "\\(TUPLE\\|SYMBOLS\\|VARS\\): ")
|
||||
'factor-font-lock-symbol)
|
||||
(t 'default))))
|
||||
((char-equal c ?U) 'factor-font-lock-parsing-word)
|
||||
((char-equal c ?\() 'factor-font-lock-stack-effect)
|
||||
((char-equal c ?\") 'factor-font-lock-string)
|
||||
(t 'factor-font-lock-comment)))))
|
||||
|
||||
(defconst fuel-font-lock--font-lock-keywords
|
||||
`((,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
|
||||
|
|
@ -135,16 +137,18 @@
|
|||
|
||||
;;; Fontify strings as Factor code:
|
||||
|
||||
(defvar fuel-font-lock--font-lock-buffer
|
||||
(let ((buffer (get-buffer-create " *fuel font lock*")))
|
||||
(set-buffer buffer)
|
||||
(set-syntax-table fuel-syntax--syntax-table)
|
||||
(fuel-font-lock--font-lock-setup)
|
||||
buffer))
|
||||
(defun fuel-font-lock--font-lock-buffer ()
|
||||
(let ((name " *fuel font lock*"))
|
||||
(or (get-buffer name)
|
||||
(let ((buffer (get-buffer-create name)))
|
||||
(set-buffer buffer)
|
||||
(set-syntax-table fuel-syntax--syntax-table)
|
||||
(fuel-font-lock--font-lock-setup)
|
||||
buffer))))
|
||||
|
||||
(defun fuel-font-lock--factor-str (str)
|
||||
(save-current-buffer
|
||||
(set-buffer fuel-font-lock--font-lock-buffer)
|
||||
(set-buffer (fuel-font-lock--font-lock-buffer))
|
||||
(erase-buffer)
|
||||
(insert str)
|
||||
(let ((font-lock-verbose nil)) (font-lock-fontify-buffer))
|
||||
|
|
|
|||
|
|
@ -177,6 +177,9 @@ interacting with a factor listener is at your disposal.
|
|||
(fuel-mode--key-1 ?l 'fuel-run-file)
|
||||
(fuel-mode--key-1 ?r 'fuel-eval-region)
|
||||
(fuel-mode--key-1 ?z 'run-factor)
|
||||
(fuel-mode--key-1 ?s 'fuel-switch-to-buffer)
|
||||
(define-key fuel-mode-map "\C-x4s" 'fuel-switch-to-buffer-other-window)
|
||||
(define-key fuel-mode-map "\C-x5s" 'fuel-switch-to-buffer-other-frame)
|
||||
|
||||
(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
|
||||
(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)
|
||||
|
|
|
|||
|
|
@ -240,14 +240,15 @@
|
|||
|
||||
(defconst fuel-syntax--syntactic-keywords
|
||||
`(;; CHARs:
|
||||
("CHAR: \\(.\\)\\( \\|$\\)" (1 "w"))
|
||||
("\\(CHAR:\\|POSTPONE:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
|
||||
;; Comments:
|
||||
("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">"))
|
||||
("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">"))
|
||||
("\\_<\\((\\) \\([^)\n]*?\\) \\()\\)\\_>" (1 "<b") (2 "w") (3 ">b"))
|
||||
;; Strings
|
||||
("\\_<\\(\"\\)\\([^\n\r\f\"]\\|\\\\\"\\)*\\(\"\\)\\_>" (1 "\"") (3 "\""))
|
||||
("\\_<<\\(\"\\)\\_>" (1 "\""))
|
||||
("\\_<\\(\"\\)>\\_>" (1 "\""))
|
||||
("\\_<<\\(\"\\)\\_>" (1 "<b"))
|
||||
("\\_<\\(\"\\)>\\_>" (1 ">b"))
|
||||
;; Multiline constructs
|
||||
("\\_<\\(U\\)SING: \\(;\\)" (1 "<b") (2 ">b"))
|
||||
("\\_<USING:\\( \\)" (1 "<b"))
|
||||
|
|
|
|||
|
|
@ -53,8 +53,10 @@ INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value)
|
|||
void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv)
|
||||
{
|
||||
default_parameters(p);
|
||||
const F_CHAR *executable_path = vm_executable_path();
|
||||
p->executable_path = executable_path ? executable_path : argv[0];
|
||||
|
||||
int i;
|
||||
int i = 0;
|
||||
|
||||
for(i = 1; i < argc; i++)
|
||||
{
|
||||
|
|
@ -107,10 +109,6 @@ void init_factor(F_PARAMETERS *p)
|
|||
if(p->image_path == NULL)
|
||||
p->image_path = default_image_path();
|
||||
|
||||
const F_CHAR *executable_path = vm_executable_path();
|
||||
if(executable_path)
|
||||
p->executable_path = executable_path;
|
||||
|
||||
srand(current_micros());
|
||||
init_ffi();
|
||||
init_stacks(p->ds_size,p->rs_size);
|
||||
|
|
|
|||
Loading…
Reference in New Issue