Fix conflict
Slava Pestov
commit
5e19766330
|
|
@ -51,6 +51,11 @@ IN: calendar.format.tests
|
|||
timestamp>string
|
||||
] unit-test
|
||||
|
||||
[ "20080504070000" ] [
|
||||
"Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp
|
||||
timestamp>mdtm
|
||||
] unit-test
|
||||
|
||||
[
|
||||
T{ timestamp f
|
||||
2008
|
||||
|
|
@ -74,3 +79,5 @@ IN: calendar.format.tests
|
|||
{ gmt-offset T{ duration f 0 0 0 0 0 0 } }
|
||||
}
|
||||
] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -78,6 +78,9 @@ M: integer year. ( n -- )
|
|||
M: timestamp year. ( timestamp -- )
|
||||
year>> year. ;
|
||||
|
||||
: timestamp>mdtm ( timestamp -- str )
|
||||
[ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
|
||||
|
||||
: (timestamp>string) ( timestamp -- )
|
||||
{ DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;
|
||||
|
||||
|
|
|
|||
|
|
@ -93,7 +93,7 @@ ERROR: ftp-error got expected ;
|
|||
: ensure-login ( url -- url )
|
||||
dup username>> [
|
||||
"anonymous" >>username
|
||||
"ftp-client" >>password
|
||||
"ftp-client@factorcode.org" >>password
|
||||
] unless ;
|
||||
|
||||
: >ftp-url ( url -- url' ) >url ensure-port ensure-login ;
|
||||
|
|
|
|||
|
|
@ -4,8 +4,7 @@ USING: accessors arrays assocs combinators io io.files kernel
|
|||
math.parser sequences strings ;
|
||||
IN: ftp
|
||||
|
||||
SINGLETON: active
|
||||
SINGLETON: passive
|
||||
SYMBOLS: +active+ +passive+ ;
|
||||
|
||||
TUPLE: ftp-response n strings parsed ;
|
||||
|
||||
|
|
@ -17,5 +16,3 @@ TUPLE: ftp-response n strings parsed ;
|
|||
over strings>> push ;
|
||||
|
||||
: ftp-send ( string -- ) write "\r\n" write flush ;
|
||||
: ftp-ipv4 1 ; inline
|
||||
: ftp-ipv6 2 ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1,50 @@
|
|||
USING: calendar ftp.server io.encodings.ascii io.files
|
||||
io.files.unique namespaces threads tools.test kernel
|
||||
io.servers.connection ftp.client accessors urls
|
||||
io.pathnames io.directories sequences fry ;
|
||||
IN: ftp.server.tests
|
||||
|
||||
: test-file-contents ( -- string )
|
||||
"Files are so boring anymore." ;
|
||||
|
||||
: create-test-file ( -- path )
|
||||
test-file-contents
|
||||
"ftp.server" "test" make-unique-file
|
||||
[ ascii set-file-contents ] keep canonicalize-path ;
|
||||
|
||||
: test-ftp-server ( quot -- )
|
||||
'[
|
||||
current-temporary-directory get 0
|
||||
<ftp-server>
|
||||
[ start-server* ]
|
||||
[
|
||||
sockets>> first addr>> port>>
|
||||
<url>
|
||||
swap >>port
|
||||
"ftp" >>protocol
|
||||
"localhost" >>host
|
||||
create-test-file >>path
|
||||
_ call
|
||||
]
|
||||
[ stop-server ] tri
|
||||
] with-unique-directory drop ; inline
|
||||
|
||||
[ t ]
|
||||
[
|
||||
|
||||
[
|
||||
unique-directory [
|
||||
[ ftp-get ] [ path>> file-name ascii file-contents ] bi
|
||||
] with-directory
|
||||
] test-ftp-server test-file-contents =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
||||
[
|
||||
"/" >>path
|
||||
unique-directory [
|
||||
[ ftp-get ] [ path>> file-name ascii file-contents ] bi
|
||||
] with-directory
|
||||
] test-ftp-server test-file-contents =
|
||||
] must-fail
|
||||
|
|
@ -1,52 +1,46 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators.short-circuit accessors combinators io
|
||||
io.encodings.8-bit io.encodings io.encodings.binary
|
||||
io.encodings.utf8 io.files io.files.info io.directories
|
||||
io.sockets kernel math.parser namespaces make sequences
|
||||
ftp io.launcher.unix.parser unicode.case splitting
|
||||
assocs classes io.servers.connection destructors calendar
|
||||
io.timeouts io.streams.duplex threads continuations math
|
||||
concurrency.promises byte-arrays io.backend tools.hexdump
|
||||
io.streams.string math.bitwise tools.files io.pathnames ;
|
||||
USING: accessors assocs byte-arrays calendar classes
|
||||
combinators combinators.short-circuit concurrency.promises
|
||||
continuations destructors ftp io io.backend io.directories
|
||||
io.encodings io.encodings.8-bit io.encodings.binary
|
||||
tools.files io.encodings.utf8 io.files io.files.info
|
||||
io.pathnames io.launcher.unix.parser io.servers.connection
|
||||
io.sockets io.streams.duplex io.streams.string io.timeouts
|
||||
kernel make math math.bitwise math.parser namespaces sequences
|
||||
splitting threads unicode.case logging calendar.format
|
||||
strings io.files.links io.files.types ;
|
||||
IN: ftp.server
|
||||
|
||||
TUPLE: ftp-client url mode state command-promise user password ;
|
||||
|
||||
: <ftp-client> ( url -- ftp-client )
|
||||
ftp-client new
|
||||
swap >>url ;
|
||||
|
||||
SYMBOL: server
|
||||
SYMBOL: client
|
||||
|
||||
: ftp-server-directory ( -- str )
|
||||
\ ftp-server-directory get-global "resource:temp" or
|
||||
normalize-path ;
|
||||
TUPLE: ftp-server < threaded-server { serving-directory string } ;
|
||||
|
||||
TUPLE: ftp-client user password extra-connection ;
|
||||
|
||||
TUPLE: ftp-command raw tokenized ;
|
||||
|
||||
: <ftp-command> ( -- obj )
|
||||
ftp-command new ;
|
||||
: <ftp-command> ( str -- obj )
|
||||
dup \ <ftp-command> DEBUG log-message
|
||||
ftp-command new
|
||||
over >>raw
|
||||
swap tokenize-command >>tokenized ;
|
||||
|
||||
TUPLE: ftp-get path ;
|
||||
|
||||
: <ftp-get> ( path -- obj )
|
||||
ftp-get new
|
||||
swap >>path ;
|
||||
|
||||
TUPLE: ftp-put path ;
|
||||
|
||||
: <ftp-put> ( path -- obj )
|
||||
ftp-put new
|
||||
swap >>path ;
|
||||
|
||||
TUPLE: ftp-list ;
|
||||
|
||||
C: <ftp-list> ftp-list
|
||||
|
||||
: read-command ( -- ftp-command )
|
||||
<ftp-command> readln
|
||||
[ >>raw ] [ tokenize-command >>tokenized ] bi ;
|
||||
TUPLE: ftp-disconnect ;
|
||||
C: <ftp-disconnect> ftp-disconnect
|
||||
|
||||
: (send-response) ( n string separator -- )
|
||||
[ number>string write ] 2dip write ftp-send ;
|
||||
|
|
@ -56,28 +50,42 @@ C: <ftp-list> ftp-list
|
|||
[ but-last-slice [ "-" (send-response) ] with each ]
|
||||
[ first " " (send-response) ] 2bi ;
|
||||
|
||||
: server-response ( n string -- )
|
||||
: server-response ( string n -- )
|
||||
2dup number>string swap ":" glue \ server-response DEBUG log-message
|
||||
<ftp-response>
|
||||
swap add-response-line
|
||||
swap >>n
|
||||
swap add-response-line
|
||||
send-response ;
|
||||
|
||||
: ftp-error ( string -- )
|
||||
500 "Unrecognized command: " rot append server-response ;
|
||||
: serving? ( path -- ? )
|
||||
canonicalize-path server get serving-directory>> head? ;
|
||||
|
||||
: can-serve-directory? ( path -- ? )
|
||||
{ [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ;
|
||||
|
||||
: can-serve-file? ( path -- ? )
|
||||
{
|
||||
[ exists? ]
|
||||
[ file-info type>> +regular-file+ = ]
|
||||
[ serving? ]
|
||||
} 1&& ;
|
||||
|
||||
: ftp-error ( string -- ) 500 server-response ;
|
||||
: ftp-unimplemented ( string -- ) 502 server-response ;
|
||||
|
||||
: send-banner ( -- )
|
||||
220 "Welcome to " host-name append server-response ;
|
||||
"Welcome to " host-name append 220 server-response ;
|
||||
|
||||
: anonymous-only ( -- )
|
||||
530 "This FTP server is anonymous only." server-response ;
|
||||
"This FTP server is anonymous only." 530 server-response ;
|
||||
|
||||
: handle-QUIT ( obj -- )
|
||||
drop 221 "Goodbye." server-response ;
|
||||
drop "Goodbye." 221 server-response ;
|
||||
|
||||
: handle-USER ( ftp-command -- )
|
||||
[
|
||||
tokenized>> second client get (>>user)
|
||||
331 "Please specify the password." server-response
|
||||
"Please specify the password." 331 server-response
|
||||
] [
|
||||
2drop "bad USER" ftp-error
|
||||
] recover ;
|
||||
|
|
@ -85,7 +93,7 @@ C: <ftp-list> ftp-list
|
|||
: handle-PASS ( ftp-command -- )
|
||||
[
|
||||
tokenized>> second client get (>>password)
|
||||
230 "Login successful" server-response
|
||||
"Login successful" 230 server-response
|
||||
] [
|
||||
2drop "PASS error" ftp-error
|
||||
] recover ;
|
||||
|
|
@ -102,7 +110,7 @@ ERROR: type-error type ;
|
|||
: handle-TYPE ( obj -- )
|
||||
[
|
||||
tokenized>> second parse-type
|
||||
[ 200 ] dip "Switching to " " mode" surround server-response
|
||||
"Switching to " " mode" surround 200 server-response
|
||||
] [
|
||||
2drop "TYPE is binary only" ftp-error
|
||||
] recover ;
|
||||
|
|
@ -115,65 +123,57 @@ ERROR: type-error type ;
|
|||
|
||||
: handle-PWD ( obj -- )
|
||||
drop
|
||||
257 current-directory get "\"" dup surround server-response ;
|
||||
current-directory get "\"" dup surround 257 server-response ;
|
||||
|
||||
: handle-SYST ( obj -- )
|
||||
drop
|
||||
215 "UNIX Type: L8" server-response ;
|
||||
|
||||
: if-command-promise ( quot -- )
|
||||
[ client get command-promise>> ] dip
|
||||
[ "Establish an active or passive connection first" ftp-error ] if* ;
|
||||
|
||||
: handle-STOR ( obj -- )
|
||||
[
|
||||
tokenized>> second
|
||||
[ [ <ftp-put> ] dip fulfill ] if-command-promise
|
||||
] [
|
||||
2drop
|
||||
] recover ;
|
||||
|
||||
! EPRT |2|::1|62138|
|
||||
! : handle-EPRT ( obj -- )
|
||||
! tokenized>> second "|" split harvest ;
|
||||
"UNIX Type: L8" 215 server-response ;
|
||||
|
||||
: start-directory ( -- )
|
||||
150 "Here comes the directory listing." server-response ;
|
||||
"Here comes the directory listing." 150 server-response ;
|
||||
|
||||
: transfer-outgoing-file ( path -- )
|
||||
[ "Opening BINARY mode data connection for " ] dip
|
||||
[ file-name ] [
|
||||
file-info size>> number>string
|
||||
"(" " bytes)." surround
|
||||
] bi " " glue append 150 server-response ;
|
||||
|
||||
: transfer-incoming-file ( path -- )
|
||||
"Opening BINARY mode data connection for " prepend
|
||||
150 server-response ;
|
||||
|
||||
: finish-file-transfer ( -- )
|
||||
"File send OK." 226 server-response ;
|
||||
|
||||
GENERIC: handle-passive-command ( stream obj -- )
|
||||
|
||||
: passive-loop ( server -- )
|
||||
[
|
||||
[
|
||||
|dispose
|
||||
30 seconds over set-timeout
|
||||
accept drop &dispose
|
||||
client get extra-connection>>
|
||||
30 seconds ?promise-timeout
|
||||
handle-passive-command
|
||||
]
|
||||
[ client get f >>extra-connection drop ]
|
||||
[ drop ] cleanup
|
||||
] with-destructors ;
|
||||
|
||||
: finish-directory ( -- )
|
||||
226 "Directory send OK." server-response ;
|
||||
"Directory send OK." 226 server-response ;
|
||||
|
||||
GENERIC: service-command ( stream obj -- )
|
||||
|
||||
M: ftp-list service-command ( stream obj -- )
|
||||
M: ftp-list handle-passive-command ( stream obj -- )
|
||||
drop
|
||||
start-directory [
|
||||
utf8 encode-output
|
||||
[ current-directory get directory. ] with-string-writer string-lines
|
||||
harvest [ ftp-send ] each
|
||||
] with-output-stream
|
||||
finish-directory ;
|
||||
] with-output-stream finish-directory ;
|
||||
|
||||
: transfer-outgoing-file ( path -- )
|
||||
[
|
||||
150
|
||||
"Opening BINARY mode data connection for "
|
||||
] dip
|
||||
[
|
||||
file-name
|
||||
] [
|
||||
file-info size>> number>string
|
||||
"(" " bytes)." surround
|
||||
] bi " " glue append server-response ;
|
||||
|
||||
: transfer-incoming-file ( path -- )
|
||||
[ 150 ] dip "Opening BINARY mode data connection for " prepend
|
||||
server-response ;
|
||||
|
||||
: finish-file-transfer ( -- )
|
||||
226 "File send OK." server-response ;
|
||||
|
||||
M: ftp-get service-command ( stream obj -- )
|
||||
M: ftp-get handle-passive-command ( stream obj -- )
|
||||
[
|
||||
path>>
|
||||
[ transfer-outgoing-file ]
|
||||
|
|
@ -183,7 +183,7 @@ M: ftp-get service-command ( stream obj -- )
|
|||
3drop "File transfer failed" ftp-error
|
||||
] recover ;
|
||||
|
||||
M: ftp-put service-command ( stream obj -- )
|
||||
M: ftp-put handle-passive-command ( stream obj -- )
|
||||
[
|
||||
path>>
|
||||
[ transfer-incoming-file ]
|
||||
|
|
@ -193,165 +193,165 @@ M: ftp-put service-command ( stream obj -- )
|
|||
3drop "File transfer failed" ftp-error
|
||||
] recover ;
|
||||
|
||||
: passive-loop ( server -- )
|
||||
[
|
||||
[
|
||||
|dispose
|
||||
30 seconds over set-timeout
|
||||
accept drop &dispose
|
||||
client get command-promise>>
|
||||
30 seconds ?promise-timeout
|
||||
service-command
|
||||
]
|
||||
[ client get f >>command-promise drop ]
|
||||
[ drop ] cleanup
|
||||
] with-destructors ;
|
||||
M: ftp-disconnect handle-passive-command ( stream obj -- )
|
||||
drop dispose ;
|
||||
|
||||
: fulfill-client ( obj -- )
|
||||
client get extra-connection>> [
|
||||
fulfill
|
||||
] [
|
||||
drop
|
||||
"Establish an active or passive connection first" ftp-error
|
||||
] if* ;
|
||||
|
||||
: handle-STOR ( obj -- )
|
||||
tokenized>> second
|
||||
dup can-serve-file? [
|
||||
<ftp-put> fulfill-client
|
||||
] [
|
||||
drop
|
||||
<ftp-disconnect> fulfill-client
|
||||
] if ;
|
||||
|
||||
: handle-LIST ( obj -- )
|
||||
drop
|
||||
[ [ <ftp-list> ] dip fulfill ] if-command-promise ;
|
||||
|
||||
: handle-SIZE ( obj -- )
|
||||
[
|
||||
[ 213 ] dip
|
||||
tokenized>> second file-info size>>
|
||||
number>string server-response
|
||||
drop current-directory get
|
||||
can-serve-directory? [
|
||||
<ftp-list> fulfill-client
|
||||
] [
|
||||
2drop
|
||||
550 "Could not get file size" server-response
|
||||
] recover ;
|
||||
<ftp-disconnect> fulfill-client
|
||||
] if ;
|
||||
|
||||
: not-a-plain-file ( path -- )
|
||||
": not a plain file." append ftp-error ;
|
||||
|
||||
: handle-RETR ( obj -- )
|
||||
[ tokenized>> second <ftp-get> swap fulfill ]
|
||||
curry if-command-promise ;
|
||||
tokenized>> second
|
||||
dup can-serve-file? [
|
||||
<ftp-get> fulfill-client
|
||||
] [
|
||||
not-a-plain-file
|
||||
<ftp-disconnect> fulfill-client
|
||||
] if ;
|
||||
|
||||
: handle-SIZE ( obj -- )
|
||||
tokenized>> second
|
||||
dup can-serve-file? [
|
||||
file-info size>> number>string 213 server-response
|
||||
] [
|
||||
not-a-plain-file
|
||||
] if ;
|
||||
|
||||
: expect-connection ( -- port )
|
||||
<promise> client get (>>extra-connection)
|
||||
random-local-server
|
||||
client get <promise> >>command-promise drop
|
||||
[ [ passive-loop ] curry in-thread ]
|
||||
[ addr>> port>> ] bi ;
|
||||
|
||||
: handle-PASV ( obj -- )
|
||||
drop client get passive >>mode drop
|
||||
221
|
||||
drop
|
||||
expect-connection port>bytes [ number>string ] bi@ "," glue
|
||||
"Entering Passive Mode (127,0,0,1," ")" surround
|
||||
server-response ;
|
||||
221 server-response ;
|
||||
|
||||
: handle-EPSV ( obj -- )
|
||||
drop
|
||||
client get command-promise>> [
|
||||
"You already have a passive stream" ftp-error
|
||||
] [
|
||||
229
|
||||
expect-connection number>string
|
||||
"Entering Extended Passive Mode (|||" "|)" surround
|
||||
server-response
|
||||
] if ;
|
||||
client get f >>extra-connection drop
|
||||
expect-connection number>string
|
||||
"Entering Extended Passive Mode (|||" "|)" surround
|
||||
229 server-response ;
|
||||
|
||||
! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186
|
||||
! : handle-LPRT ( obj -- ) tokenized>> "," split ;
|
||||
|
||||
ERROR: not-a-directory ;
|
||||
ERROR: no-permissions ;
|
||||
|
||||
: handle-CWD ( obj -- )
|
||||
[
|
||||
tokenized>> second dup normalize-path
|
||||
dup ftp-server-directory head? [
|
||||
no-permissions
|
||||
] unless
|
||||
|
||||
file-info directory? [
|
||||
set-current-directory
|
||||
250 "Directory successully changed." server-response
|
||||
: handle-MDTM ( obj -- )
|
||||
tokenized>> 1 swap ?nth [
|
||||
dup file-info dup directory? [
|
||||
drop not-a-plain-file
|
||||
] [
|
||||
not-a-directory
|
||||
nip
|
||||
modified>> timestamp>mdtm
|
||||
213 server-response
|
||||
] if
|
||||
] [
|
||||
2drop
|
||||
550 "Failed to change directory." server-response
|
||||
] recover ;
|
||||
"" not-a-plain-file
|
||||
] if* ;
|
||||
|
||||
: unrecognized-command ( obj -- ) raw>> ftp-error ;
|
||||
ERROR: not-a-directory ;
|
||||
ERROR: no-directory-permissions ;
|
||||
|
||||
: handle-client-loop ( -- )
|
||||
<ftp-command> readln
|
||||
USE: prettyprint global [ dup . flush ] bind
|
||||
[ >>raw ]
|
||||
[ tokenize-command >>tokenized ] bi
|
||||
: directory-change-success ( -- )
|
||||
"Directory successully changed." 250 server-response ;
|
||||
|
||||
: directory-change-failed ( -- )
|
||||
"Failed to change directory." 553 server-response ;
|
||||
|
||||
: handle-CWD ( obj -- )
|
||||
tokenized>> 1 swap ?nth [
|
||||
dup can-serve-directory? [
|
||||
set-current-directory
|
||||
directory-change-success
|
||||
] [
|
||||
drop
|
||||
directory-change-failed
|
||||
] if
|
||||
] [
|
||||
directory-change-success
|
||||
] if* ;
|
||||
|
||||
: unrecognized-command ( obj -- )
|
||||
raw>> "Unrecognized command: " prepend ftp-error ;
|
||||
|
||||
: client-loop-dispatch ( str/f -- ? )
|
||||
dup tokenized>> first >upper {
|
||||
{ "QUIT" [ handle-QUIT f ] }
|
||||
{ "USER" [ handle-USER t ] }
|
||||
{ "PASS" [ handle-PASS t ] }
|
||||
{ "ACCT" [ drop "ACCT unimplemented" ftp-error t ] }
|
||||
{ "CWD" [ handle-CWD t ] }
|
||||
! { "XCWD" [ ] }
|
||||
! { "CDUP" [ ] }
|
||||
! { "SMNT" [ ] }
|
||||
|
||||
! { "REIN" [ drop client get reset-ftp-client t ] }
|
||||
{ "QUIT" [ handle-QUIT f ] }
|
||||
|
||||
! { "PORT" [ ] } ! TODO
|
||||
{ "PASV" [ handle-PASV t ] }
|
||||
! { "MODE" [ ] }
|
||||
{ "TYPE" [ handle-TYPE t ] }
|
||||
! { "STRU" [ ] }
|
||||
|
||||
! { "ALLO" [ ] }
|
||||
! { "REST" [ ] }
|
||||
{ "STOR" [ handle-STOR t ] }
|
||||
! { "STOU" [ ] }
|
||||
{ "RETR" [ handle-RETR t ] }
|
||||
{ "LIST" [ handle-LIST t ] }
|
||||
{ "SIZE" [ handle-SIZE t ] }
|
||||
! { "NLST" [ ] }
|
||||
! { "APPE" [ ] }
|
||||
! { "RNFR" [ ] }
|
||||
! { "RNTO" [ ] }
|
||||
! { "DELE" [ handle-DELE t ] }
|
||||
! { "RMD" [ handle-RMD t ] }
|
||||
! ! { "XRMD" [ handle-XRMD t ] }
|
||||
! { "MKD" [ handle-MKD t ] }
|
||||
{ "PWD" [ handle-PWD t ] }
|
||||
! { "ABOR" [ ] }
|
||||
|
||||
{ "SYST" [ handle-SYST t ] }
|
||||
! { "STAT" [ ] }
|
||||
! { "HELP" [ ] }
|
||||
|
||||
! { "SITE" [ ] }
|
||||
! { "NOOP" [ ] }
|
||||
|
||||
! { "EPRT" [ handle-EPRT ] }
|
||||
! { "LPRT" [ handle-LPRT ] }
|
||||
{ "ACCT" [ drop "ACCT unimplemented" ftp-unimplemented t ] }
|
||||
{ "PWD" [ handle-PWD t ] }
|
||||
{ "TYPE" [ handle-TYPE t ] }
|
||||
{ "CWD" [ handle-CWD t ] }
|
||||
{ "PASV" [ handle-PASV t ] }
|
||||
{ "EPSV" [ handle-EPSV t ] }
|
||||
! { "LPSV" [ drop handle-LPSV t ] }
|
||||
{ "LIST" [ handle-LIST t ] }
|
||||
{ "STOR" [ handle-STOR t ] }
|
||||
{ "RETR" [ handle-RETR t ] }
|
||||
{ "SIZE" [ handle-SIZE t ] }
|
||||
{ "MDTM" [ handle-MDTM t ] }
|
||||
[ drop unrecognized-command t ]
|
||||
} case [ handle-client-loop ] when ;
|
||||
} case ;
|
||||
|
||||
TUPLE: ftp-server < threaded-server ;
|
||||
: read-command ( -- ftp-command/f )
|
||||
readln [ f ] [ <ftp-command> ] if-empty ;
|
||||
|
||||
: handle-client-loop ( -- )
|
||||
read-command [
|
||||
client-loop-dispatch
|
||||
[ handle-client-loop ] when
|
||||
] when* ;
|
||||
|
||||
: serve-directory ( server -- )
|
||||
serving-directory>> [
|
||||
send-banner
|
||||
handle-client-loop
|
||||
] with-directory ;
|
||||
|
||||
M: ftp-server handle-client* ( server -- )
|
||||
drop
|
||||
[
|
||||
ftp-server-directory [
|
||||
host-name <ftp-client> client set
|
||||
send-banner handle-client-loop
|
||||
] with-directory
|
||||
"New client" \ handle-client* DEBUG log-message
|
||||
ftp-client new client set
|
||||
[ server set ] [ serve-directory ] bi
|
||||
] with-destructors ;
|
||||
|
||||
: <ftp-server> ( port -- server )
|
||||
: <ftp-server> ( directory port -- server )
|
||||
ftp-server new-threaded-server
|
||||
swap >>insecure
|
||||
swap canonicalize-path >>serving-directory
|
||||
"ftp.server" >>name
|
||||
5 minutes >>timeout
|
||||
latin1 >>encoding ;
|
||||
|
||||
: ftpd ( port -- )
|
||||
: ftpd ( directory port -- )
|
||||
<ftp-server> start-server ;
|
||||
|
||||
: ftpd-main ( -- ) 2100 ftpd ;
|
||||
: ftpd-main ( path -- ) 2100 ftpd ;
|
||||
|
||||
MAIN: ftpd-main
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2009 Yun, Jonghyouk.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.syntax help.markup ;
|
||||
IN: io.encodings.korean
|
||||
|
||||
ARTICLE: "io.encodings.korean" "Korean text encodings"
|
||||
"The " { $vocab-link "io.encodings.korean" } " vocabulary implements encodings used for Korean text besides the standard UTF encodings for Unicode strings."
|
||||
{ $subsection cp949 } ;
|
||||
|
||||
ABOUT: "io.encodings.korean"
|
||||
|
||||
HELP: cp949
|
||||
{ $class-description "This encoding class implements Microsoft's code page #949 encoding, also called Unified Hangul Code or ks_c_5601-1987, UHC. CP949 is extended version of EUC-KR and downward-compatibility to EUC-KR. " }
|
||||
{ $see-also "encodings-introduction" } ;
|
||||
|
|
@ -6,6 +6,8 @@ math.order math.parser memoize multiline sequences splitting
|
|||
values hashtables io.binary ;
|
||||
IN: io.encodings.korean
|
||||
|
||||
! TODO: migrate to common code-table parser (by Dan).
|
||||
|
||||
SINGLETON: cp949
|
||||
|
||||
cp949 "EUC-KR" register-encoding
|
||||
|
|
|
|||
|
|
@ -72,13 +72,14 @@ M: linux file-systems
|
|||
] map ;
|
||||
|
||||
: (find-mount-point) ( path mtab-paths -- mtab-entry )
|
||||
[ follow-links ] dip 2dup at* [
|
||||
2dup at* [
|
||||
2nip
|
||||
] [
|
||||
drop [ parent-directory ] dip (find-mount-point)
|
||||
] if ;
|
||||
|
||||
: find-mount-point ( path -- mtab-entry )
|
||||
canonicalize-path
|
||||
parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ;
|
||||
|
||||
ERROR: file-system-not-found ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.backend io.files.links system unix ;
|
||||
USING: io.backend io.files.links system unix io.pathnames kernel
|
||||
io.files sequences ;
|
||||
IN: io.files.links.unix
|
||||
|
||||
M: unix make-link ( path1 path2 -- )
|
||||
|
|
@ -8,3 +9,7 @@ M: unix make-link ( path1 path2 -- )
|
|||
|
||||
M: unix read-link ( path -- path' )
|
||||
normalize-path read-symbolic-link ;
|
||||
|
||||
M: unix canonicalize-path ( path -- path' )
|
||||
path-components "/"
|
||||
[ append-path dup exists? [ follow-links ] when ] reduce ;
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ IN: io.servers.connection
|
|||
|
||||
TUPLE: threaded-server
|
||||
name
|
||||
log-level
|
||||
secure insecure
|
||||
secure-config
|
||||
sockets
|
||||
|
|
@ -29,6 +30,7 @@ ready ;
|
|||
: new-threaded-server ( class -- threaded-server )
|
||||
new
|
||||
"server" >>name
|
||||
DEBUG >>log-level
|
||||
ascii >>encoding
|
||||
1 minutes >>timeout
|
||||
V{ } clone >>sockets
|
||||
|
|
@ -115,7 +117,7 @@ M: threaded-server handle-client* handler>> call ;
|
|||
: (start-server) ( threaded-server -- )
|
||||
init-server
|
||||
dup threaded-server [
|
||||
dup name>> [
|
||||
[ ] [ name>> ] bi [
|
||||
[ listen-on [ start-accept-loop ] parallel-each ]
|
||||
[ ready>> raise-flag ]
|
||||
bi
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
IN: io.servers.datagram
|
||||
USING: concurrency.combinators destructors fry
|
||||
io.sockets kernel logging ;
|
||||
IN: io.servers.packet
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -8,6 +8,9 @@ HELP: DEBUG
|
|||
HELP: NOTICE
|
||||
{ $description "Log level for ordinary messages." } ;
|
||||
|
||||
HELP: WARNING
|
||||
{ $description "Log level for warnings." } ;
|
||||
|
||||
HELP: ERROR
|
||||
{ $description "Log level for error messages." } ;
|
||||
|
||||
|
|
@ -18,6 +21,7 @@ ARTICLE: "logging.levels" "Log levels"
|
|||
"Several log levels are supported, from lowest to highest:"
|
||||
{ $subsection DEBUG }
|
||||
{ $subsection NOTICE }
|
||||
{ $subsection WARNING }
|
||||
{ $subsection ERROR }
|
||||
{ $subsection CRITICAL } ;
|
||||
|
||||
|
|
@ -36,7 +40,7 @@ ARTICLE: "logging.files" "Log files"
|
|||
|
||||
HELP: log-message
|
||||
{ $values { "msg" string } { "word" word } { "level" "a log level" } }
|
||||
{ $description "Sends a message to the current log. Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ;
|
||||
{ $description "Sends a message to the current log if the level is more urgent than " { $link log-level } ". Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ;
|
||||
|
||||
HELP: add-logging
|
||||
{ $values { "level" "a log level" } { "word" word } }
|
||||
|
|
@ -91,7 +95,7 @@ HELP: close-logs
|
|||
|
||||
HELP: with-logging
|
||||
{ $values { "service" "a log service name" } { "quot" quotation } }
|
||||
{ $description "Calls the quotation a new dynamic scope where all logging calls are sent to the log file for " { $snippet "service" } "." } ;
|
||||
{ $description "Calls the quotation a new dynamic scope where all logging calls more urgent than " { $link log-level } " are sent to the log file for " { $snippet "service" } "." } ;
|
||||
|
||||
ARTICLE: "logging.rotation" "Log rotation"
|
||||
"Log files should be rotated periodically to prevent unbounded growth."
|
||||
|
|
@ -120,4 +124,3 @@ ARTICLE: "logging" "Logging framework"
|
|||
{ $subsection "logging.server" } ;
|
||||
|
||||
ABOUT: "logging"
|
||||
|
||||
|
|
|
|||
|
|
@ -4,25 +4,47 @@ USING: logging.server sequences namespaces concurrency.messaging
|
|||
words kernel arrays shuffle tools.annotations
|
||||
prettyprint.config prettyprint debugger io.streams.string
|
||||
splitting continuations effects generalizations parser strings
|
||||
quotations fry accessors ;
|
||||
quotations fry accessors math assocs math.order ;
|
||||
IN: logging
|
||||
|
||||
SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;
|
||||
|
||||
: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
|
||||
SYMBOL: log-level
|
||||
|
||||
log-level [ DEBUG ] initialize
|
||||
|
||||
: log-levels ( -- assoc )
|
||||
H{
|
||||
{ DEBUG 0 }
|
||||
{ NOTICE 10 }
|
||||
{ WARNING 20 }
|
||||
{ ERROR 30 }
|
||||
{ CRITICAL 40 }
|
||||
} ;
|
||||
|
||||
ERROR: undefined-log-level ;
|
||||
|
||||
: log-level<=> ( log-level log-level -- ? )
|
||||
[ log-levels at* [ undefined-log-level ] unless ] bi@ <=> ;
|
||||
|
||||
: log? ( log-level -- ? )
|
||||
log-level get log-level<=> +lt+ = not ;
|
||||
|
||||
: send-to-log-server ( array string -- )
|
||||
prefix "log-server" get send ;
|
||||
|
||||
SYMBOL: log-service
|
||||
|
||||
ERROR: bad-log-message-parameters msg word level ;
|
||||
|
||||
: check-log-message ( msg word level -- msg word level )
|
||||
3dup [ string? ] [ word? ] [ word? ] tri* and and
|
||||
[ "Bad parameters to log-message" throw ] unless ; inline
|
||||
[ bad-log-message-parameters ] unless ; inline
|
||||
|
||||
: log-message ( msg word level -- )
|
||||
check-log-message
|
||||
log-service get dup [
|
||||
log-service get
|
||||
2dup [ log? ] [ ] bi* and [
|
||||
[ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip
|
||||
4array "log-message" send-to-log-server
|
||||
] [
|
||||
|
|
@ -36,7 +58,7 @@ SYMBOL: log-service
|
|||
{ } "close-logs" send-to-log-server ;
|
||||
|
||||
: with-logging ( service quot -- )
|
||||
log-service swap with-variable ; inline
|
||||
[ log-service ] dip with-variable ; inline
|
||||
|
||||
! Aspect-oriented programming idioms
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors peg peg.parsers memoize kernel sequences
|
||||
logging arrays words strings vectors io io.files
|
||||
io.encodings.utf8 namespaces make combinators logging.server
|
||||
calendar calendar.format ;
|
||||
calendar calendar.format assocs ;
|
||||
IN: logging.parser
|
||||
|
||||
TUPLE: log-entry date level word-name message ;
|
||||
|
|
@ -21,7 +21,7 @@ SYMBOL: multiline
|
|||
"[" "]" surrounded-by ;
|
||||
|
||||
: 'log-level' ( -- parser )
|
||||
log-levels [
|
||||
log-levels keys [
|
||||
[ name>> token ] keep [ nip ] curry action
|
||||
] map choice ;
|
||||
|
||||
|
|
|
|||
|
|
@ -252,10 +252,14 @@ M: real tanh ftanh ;
|
|||
|
||||
: -i* ( x -- y ) >rect swap neg rect> ;
|
||||
|
||||
: asin ( x -- y )
|
||||
GENERIC: asin ( x -- y ) foldable
|
||||
|
||||
M: number asin
|
||||
dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline
|
||||
|
||||
: acos ( x -- y )
|
||||
GENERIC: acos ( x -- y ) foldable
|
||||
|
||||
M: number acos
|
||||
dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ;
|
||||
inline
|
||||
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ ARTICLE: "inference-recursive" "Stack effects of recursive words"
|
|||
"When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect."
|
||||
$nl
|
||||
"Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":"
|
||||
{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if" "[ foo ] infer." }
|
||||
{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if ;" "[ foo ] infer." }
|
||||
"If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ;
|
||||
|
||||
ARTICLE: "inference-recursive-combinators" "Recursive combinator inference"
|
||||
|
|
|
|||
|
|
@ -35,9 +35,10 @@ IN: tools.files
|
|||
|
||||
PRIVATE>
|
||||
|
||||
SYMBOLS: file-name file-name/type permissions file-type nlinks file-size
|
||||
file-date file-time file-datetime uid gid user group link-target unix-datetime
|
||||
directory-or-size ;
|
||||
SYMBOLS: +file-name+ +file-name/type+ +permissions+ +file-type+
|
||||
+nlinks+ +file-size+ +file-date+ +file-time+ +file-datetime+
|
||||
+uid+ +gid+ +user+ +group+ +link-target+ +unix-datetime+
|
||||
+directory-or-size+ ;
|
||||
|
||||
TUPLE: listing-tool path specs sort ;
|
||||
|
||||
|
|
@ -48,10 +49,10 @@ C: <file-listing> file-listing
|
|||
: <listing-tool> ( path -- listing-tool )
|
||||
listing-tool new
|
||||
swap >>path
|
||||
{ file-name } >>specs ;
|
||||
{ +file-name+ } >>specs ;
|
||||
|
||||
: list-slow? ( listing-tool -- ? )
|
||||
specs>> { file-name } sequence= not ;
|
||||
specs>> { +file-name+ } sequence= not ;
|
||||
|
||||
ERROR: unknown-file-spec symbol ;
|
||||
|
||||
|
|
@ -59,12 +60,12 @@ HOOK: file-spec>string os ( file-listing spec -- string )
|
|||
|
||||
M: object file-spec>string ( file-listing spec -- string )
|
||||
{
|
||||
{ file-name [ directory-entry>> name>> ] }
|
||||
{ directory-or-size [ file-info>> dir-or-size ] }
|
||||
{ file-size [ file-info>> size>> number>string ] }
|
||||
{ file-date [ file-info>> modified>> listing-date ] }
|
||||
{ file-time [ file-info>> modified>> listing-time ] }
|
||||
{ file-datetime [ file-info>> modified>> timestamp>ymdhms ] }
|
||||
{ +file-name+ [ directory-entry>> name>> ] }
|
||||
{ +directory-or-size+ [ file-info>> dir-or-size ] }
|
||||
{ +file-size+ [ file-info>> size>> number>string ] }
|
||||
{ +file-date+ [ file-info>> modified>> listing-date ] }
|
||||
{ +file-time+ [ file-info>> modified>> listing-time ] }
|
||||
{ +file-datetime+ [ file-info>> modified>> timestamp>ymdhms ] }
|
||||
[ unknown-file-spec ]
|
||||
} case ;
|
||||
|
||||
|
|
@ -85,22 +86,22 @@ HOOK: (directory.) os ( path -- lines )
|
|||
|
||||
: directory. ( path -- ) (directory.) simple-table. ;
|
||||
|
||||
SYMBOLS: device-name mount-point type
|
||||
available-space free-space used-space total-space
|
||||
percent-used percent-free ;
|
||||
SYMBOLS: +device-name+ +mount-point+ +type+
|
||||
+available-space+ +free-space+ +used-space+ +total-space+
|
||||
+percent-used+ +percent-free+ ;
|
||||
|
||||
: percent ( real -- integer ) 100 * >integer ; inline
|
||||
|
||||
: file-system-spec ( file-system-info obj -- str )
|
||||
{
|
||||
{ device-name [ device-name>> "" or ] }
|
||||
{ mount-point [ mount-point>> "" or ] }
|
||||
{ type [ type>> "" or ] }
|
||||
{ available-space [ available-space>> 0 or ] }
|
||||
{ free-space [ free-space>> 0 or ] }
|
||||
{ used-space [ used-space>> 0 or ] }
|
||||
{ total-space [ total-space>> 0 or ] }
|
||||
{ percent-used [
|
||||
{ +device-name+ [ device-name>> "" or ] }
|
||||
{ +mount-point+ [ mount-point>> "" or ] }
|
||||
{ +type+ [ type>> "" or ] }
|
||||
{ +available-space+ [ available-space>> 0 or ] }
|
||||
{ +free-space+ [ free-space>> 0 or ] }
|
||||
{ +used-space+ [ used-space>> 0 or ] }
|
||||
{ +total-space+ [ total-space>> 0 or ] }
|
||||
{ +percent-used+ [
|
||||
[ used-space>> ] [ total-space>> ] bi
|
||||
[ 0 or ] bi@ dup 0 =
|
||||
[ 2drop 0 ] [ / percent ] if
|
||||
|
|
@ -116,8 +117,8 @@ percent-used percent-free ;
|
|||
|
||||
: file-systems. ( -- )
|
||||
{
|
||||
device-name available-space free-space used-space
|
||||
total-space percent-used mount-point
|
||||
+device-name+ +available-space+ +free-space+ +used-space+
|
||||
+total-space+ +percent-used+ +mount-point+
|
||||
} print-file-systems ;
|
||||
|
||||
{
|
||||
|
|
|
|||
|
|
@ -47,21 +47,24 @@ IN: tools.files.unix
|
|||
|
||||
M: unix (directory.) ( path -- lines )
|
||||
<listing-tool>
|
||||
{ permissions nlinks user group file-size file-date file-name } >>specs
|
||||
{
|
||||
+permissions+ +nlinks+ +user+ +group+
|
||||
+file-size+ +file-date+ +file-name+
|
||||
} >>specs
|
||||
{ { directory-entry>> name>> <=> } } >>sort
|
||||
[ [ list-files ] with-group-cache ] with-user-cache ;
|
||||
|
||||
M: unix file-spec>string ( file-listing spec -- string )
|
||||
{
|
||||
{ file-name/type [
|
||||
{ +file-name/type+ [
|
||||
directory-entry>> [ name>> ] [ file-type>trailing ] bi append
|
||||
] }
|
||||
{ permissions [ file-info>> permissions-string ] }
|
||||
{ nlinks [ file-info>> nlink>> number>string ] }
|
||||
{ user [ file-info>> uid>> user-name ] }
|
||||
{ group [ file-info>> gid>> group-name ] }
|
||||
{ uid [ file-info>> uid>> number>string ] }
|
||||
{ gid [ file-info>> gid>> number>string ] }
|
||||
{ +permissions+ [ file-info>> permissions-string ] }
|
||||
{ +nlinks+ [ file-info>> nlink>> number>string ] }
|
||||
{ +user+ [ file-info>> uid>> user-name ] }
|
||||
{ +group+ [ file-info>> gid>> group-name ] }
|
||||
{ +uid+ [ file-info>> uid>> number>string ] }
|
||||
{ +gid+ [ file-info>> gid>> number>string ] }
|
||||
[ call-next-method ]
|
||||
} case ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: tools.files.windows
|
|||
|
||||
M: windows (directory.) ( entries -- lines )
|
||||
<listing-tool>
|
||||
{ file-datetime directory-or-size file-name } >>specs
|
||||
{ +file-datetime+ +directory-or-size+ +file-name+ } >>specs
|
||||
{ { directory-entry>> name>> <=> } } >>sort
|
||||
list-files ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
USING: help.markup help.syntax io.backend io.files io.directories strings ;
|
||||
USING: help.markup help.syntax io.backend io.files io.directories strings
|
||||
sequences ;
|
||||
IN: io.pathnames
|
||||
|
||||
HELP: path-separator?
|
||||
|
|
@ -22,6 +23,10 @@ HELP: file-name
|
|||
{ $example "USING: io.pathnames prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
|
||||
} ;
|
||||
|
||||
HELP: path-components
|
||||
{ $values { "path" "a pathnames string" } { "seq" sequence } }
|
||||
{ $description "Splits a pathname on the " { $link path-separator } " into its its component strings." } ;
|
||||
|
||||
HELP: append-path
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
|
||||
{ $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ;
|
||||
|
|
@ -65,6 +70,10 @@ HELP: normalize-path
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: canonicalize-path
|
||||
{ $values { "path" "a pathname string" } { "path'" "a new pathname string" } }
|
||||
{ $description "Returns an canonical name for a path. The canonical name is an absolute path containing no symlinks." } ;
|
||||
|
||||
HELP: <pathname>
|
||||
{ $values { "string" "a pathname string" } { "pathname" pathname } }
|
||||
{ $description "Creates a new " { $link pathname } "." } ;
|
||||
|
|
@ -78,7 +87,10 @@ ARTICLE: "io.pathnames" "Pathname manipulation"
|
|||
{ $subsection parent-directory }
|
||||
{ $subsection file-name }
|
||||
{ $subsection last-path-separator }
|
||||
{ $subsection path-components }
|
||||
{ $subsection prepend-path }
|
||||
{ $subsection append-path }
|
||||
{ $subsection canonicalize-path }
|
||||
"Pathname presentations:"
|
||||
{ $subsection pathname }
|
||||
{ $subsection <pathname> }
|
||||
|
|
|
|||
|
|
@ -66,3 +66,7 @@ IN: io.pathnames.tests
|
|||
] with-scope
|
||||
|
||||
[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
|
||||
|
||||
! Regression test for bug in file-extension
|
||||
[ f ] [ "/funny.directory/file-with-no-extension" file-extension ] unit-test
|
||||
[ "" ] [ "/funny.directory/file-with-no-extension." file-extension ] unit-test
|
||||
|
|
|
|||
|
|
@ -119,7 +119,14 @@ PRIVATE>
|
|||
] unless ;
|
||||
|
||||
: file-extension ( filename -- extension )
|
||||
"." split1-last nip ;
|
||||
file-name "." split1-last nip ;
|
||||
|
||||
: path-components ( path -- seq )
|
||||
normalize-path path-separator split harvest ;
|
||||
|
||||
HOOK: canonicalize-path os ( path -- path' )
|
||||
|
||||
M: object canonicalize-path normalize-path ;
|
||||
|
||||
: resource-path ( path -- newpath )
|
||||
"resource-path" get prepend-path ;
|
||||
|
|
|
|||
|
|
@ -9,6 +9,22 @@ IN: annotations
|
|||
: comment-usage.-word ( base -- word ) "s." append "annotations" lookup ;
|
||||
PRIVATE>
|
||||
|
||||
: $annotation ( element -- )
|
||||
first
|
||||
[ "!" " your comment here" surround 1array $syntax ]
|
||||
[ [ "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 3array $description ]
|
||||
[ ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 1array $unchecked-example ]
|
||||
tri ;
|
||||
|
||||
: $annotation-usage. ( element -- )
|
||||
first
|
||||
[ "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 3array $description ;
|
||||
|
||||
: $annotation-usage ( element -- )
|
||||
first
|
||||
{ "usages" sequence } $values
|
||||
[ "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray ] bi 1array $description ;
|
||||
|
||||
"Code annotations"
|
||||
{
|
||||
"The " { $vocab-link "annotations" } " vocabulary provides syntax for comment-like annotations that can be looked up with Factor's " { $link usage } " mechanism."
|
||||
|
|
@ -26,17 +42,9 @@ annotation-tags natural-sort
|
|||
|
||||
annotation-tags [
|
||||
{
|
||||
[ [ \ $syntax ] dip "!" " your comment here" surround 2array ]
|
||||
[ [ \ $description "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 4array ]
|
||||
[ [ \ $unchecked-example ] dip ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 2array 3array ]
|
||||
[ comment-word set-word-help ]
|
||||
|
||||
[ [ \ $description "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 4array 1array ]
|
||||
[ comment-usage.-word set-word-help ]
|
||||
|
||||
[ [ { $values { "usages" sequence } } \ $description "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray 2array ] bi ]
|
||||
[ comment-usage-word set-word-help ]
|
||||
|
||||
[ [ \ $annotation swap 2array 1array ] [ comment-word set-word-help ] bi ]
|
||||
[ [ \ $annotation-usage swap 2array 1array ] [ comment-usage-word set-word-help ] bi ]
|
||||
[ [ \ $annotation-usage. swap 2array 1array ] [ comment-usage.-word set-word-help ] bi ]
|
||||
[ [ comment-word ] [ comment-usage-word ] [ comment-usage.-word ] tri 3array related-words ]
|
||||
} cleave
|
||||
] each
|
||||
|
|
|
|||
|
|
@ -99,6 +99,8 @@ PRIVATE>
|
|||
|
||||
: fuel-vocab-help ( name -- ) (fuel-vocab-help) fuel-eval-set-result ;
|
||||
|
||||
: fuel-word-synopsis ( word usings -- ) (fuel-word-synopsis) fuel-eval-set-result ;
|
||||
|
||||
: fuel-vocab-summary ( name -- )
|
||||
(fuel-vocab-summary) fuel-eval-set-result ;
|
||||
|
||||
|
|
|
|||
|
|
@ -90,6 +90,12 @@ PRIVATE>
|
|||
: (fuel-word-help) ( name -- elem )
|
||||
fuel-find-word [ [ auto-use? on (fuel-word-element) ] with-scope ] [ f ] if* ;
|
||||
|
||||
: (fuel-word-synopsis) ( word usings -- str/f )
|
||||
[
|
||||
[ vocab ] filter interactive-vocabs get append interactive-vocabs set
|
||||
fuel-find-word [ synopsis ] when*
|
||||
] with-scope ;
|
||||
|
||||
: (fuel-word-see) ( word -- elem )
|
||||
[ name>> \ article swap ]
|
||||
[ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline
|
||||
|
|
|
|||
|
|
@ -1,13 +1,19 @@
|
|||
! Copyright (C) 2008 Tim Wawrzynczak
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax sequences kernel ;
|
||||
USING: help.markup help.syntax sequences kernel accessors ;
|
||||
IN: id3
|
||||
|
||||
HELP: file-id3-tags
|
||||
{ $values
|
||||
{ "path" "a path string" }
|
||||
{ "object/f" "a tuple storing ID3 metadata or f" } }
|
||||
{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present." } ;
|
||||
{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Currently, the parser supports the following tags: "
|
||||
$nl { $link title>> }
|
||||
$nl { $link artist>> }
|
||||
$nl { $link album>> }
|
||||
$nl { $link year>> }
|
||||
$nl { $link genre>> }
|
||||
$nl { $link comment>> } } ;
|
||||
|
||||
ARTICLE: "id3" "ID3 tags"
|
||||
"The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl
|
||||
|
|
|
|||
|
|
@ -1,182 +1,35 @@
|
|||
! Copyright (C) 2009 Tim Wawrzynczak
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test id3 ;
|
||||
USING: tools.test id3 id3.private ;
|
||||
IN: id3.tests
|
||||
|
||||
[ T{ mp3v2-file
|
||||
{ header T{ header f t 0 502 } }
|
||||
{ frames
|
||||
{
|
||||
T{ frame
|
||||
{ frame-id "COMM" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 19 }
|
||||
{ data "eng, AG# 08E1C12E" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TIT2" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 15 }
|
||||
{ data "Stormy Weather" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TRCK" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 3 }
|
||||
{ data "32" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TCON" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 5 }
|
||||
{ data "(96)" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TALB" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 28 }
|
||||
{ data "Night and Day Frank Sinatra" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "PRIV" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 39 }
|
||||
{ data "WM/MediaClassPrimaryID<49>}`<60>#<23><>K<EFBFBD>H<EFBFBD>*(D" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "PRIV" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 41 }
|
||||
{ data "WM/MediaClassSecondaryID" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TPE1" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 14 }
|
||||
{ data "Frank Sinatra" }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test
|
||||
[
|
||||
T{ id3-info
|
||||
{ title "BLAH" }
|
||||
{ artist "ARTIST" }
|
||||
{ album "ALBUM" }
|
||||
{ year "2009" }
|
||||
{ comment "COMMENT" }
|
||||
{ genre "Bluegrass" }
|
||||
}
|
||||
] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test
|
||||
|
||||
[
|
||||
T{ mp3v2-file
|
||||
{ header
|
||||
T{ header { version t } { flags 0 } { size 1405 } }
|
||||
T{ id3-info
|
||||
{ title "Anthem of the Trinity" }
|
||||
{ artist "Terry Riley" }
|
||||
{ album "Shri Camel" }
|
||||
{ genre "Classical" }
|
||||
}
|
||||
{ frames
|
||||
{
|
||||
T{ frame
|
||||
{ frame-id "TIT2" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 22 }
|
||||
{ data "Anthem of the Trinity" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TPE1" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 12 }
|
||||
{ data "Terry Riley" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TALB" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 11 }
|
||||
{ data "Shri Camel" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TCON" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 10 }
|
||||
{ data "Classical" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "UFID" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 23 }
|
||||
{ data "http://musicbrainz.org" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TXXX" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 23 }
|
||||
{ data "MusicBrainz Artist Id" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TXXX" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 22 }
|
||||
{ data "musicbrainz_artistid" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TRCK" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 2 }
|
||||
{ data "1" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TXXX" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 22 }
|
||||
{ data "MusicBrainz Album Id" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TXXX" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 21 }
|
||||
{ data "musicbrainz_albumid" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TXXX" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 29 }
|
||||
{ data "MusicBrainz Album Artist Id" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TXXX" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 27 }
|
||||
{ data "musicbrainz_albumartistid" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TPOS" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 2 }
|
||||
{ data "1" }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TSOP" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 1 }
|
||||
}
|
||||
T{ frame
|
||||
{ frame-id "TMED" }
|
||||
{ flags B{ 0 0 } }
|
||||
{ size 4 }
|
||||
{ data "DIG" }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags ] unit-test
|
||||
|
||||
[
|
||||
T{ mp3v1-file
|
||||
{ title
|
||||
"BLAH"
|
||||
}
|
||||
{ artist
|
||||
"ARTIST"
|
||||
}
|
||||
{ album
|
||||
"ALBUM"
|
||||
}
|
||||
{ year "2009" }
|
||||
{ comment
|
||||
"COMMENT"
|
||||
}
|
||||
{ genre 89 }
|
||||
}
|
||||
] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test
|
||||
T{ id3-info
|
||||
{ title "Stormy Weather" }
|
||||
{ artist "Frank Sinatra" }
|
||||
{ album "Night and Day Frank Sinatra" }
|
||||
{ comment "eng, AG# 08E1C12E" }
|
||||
{ genre "Big Band" }
|
||||
}
|
||||
] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,28 +1,159 @@
|
|||
! Copyright (C) 2009 Tim Wawrzynczak
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays prettyprint io.encodings.string io.encodings.ascii ;
|
||||
USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays io.encodings.string io.encodings.utf8 assocs math.parser ;
|
||||
IN: id3
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! genres
|
||||
CONSTANT: genres
|
||||
H{
|
||||
{ 0 "Blues" }
|
||||
{ 1 "Classic Rock" }
|
||||
{ 2 "Country" }
|
||||
{ 3 "Dance" }
|
||||
{ 4 "Disco" }
|
||||
{ 5 "Funk" }
|
||||
{ 6 "Grunge" }
|
||||
{ 7 "Hip-Hop" }
|
||||
{ 8 "Jazz" }
|
||||
{ 9 "Metal" }
|
||||
{ 10 "New Age" }
|
||||
{ 11 "Oldies" }
|
||||
{ 12 "Other" }
|
||||
{ 13 "Pop" }
|
||||
{ 14 "R&B" }
|
||||
{ 15 "Rap" }
|
||||
{ 16 "Reggae" }
|
||||
{ 17 "Rock" }
|
||||
{ 18 "Techno" }
|
||||
{ 19 "Industrial" }
|
||||
{ 20 "Alternative" }
|
||||
{ 21 "Ska" }
|
||||
{ 22 "Death Metal" }
|
||||
{ 23 "Pranks" }
|
||||
{ 24 "Soundtrack" }
|
||||
{ 25 "Euro-Techno" }
|
||||
{ 26 "Ambient" }
|
||||
{ 27 "Trip-Hop" }
|
||||
{ 28 "Vocal" }
|
||||
{ 29 "Jazz+Funk" }
|
||||
{ 30 "Fusion" }
|
||||
{ 31 "Trance" }
|
||||
{ 32 "Classical" }
|
||||
{ 33 "Instrumental" }
|
||||
{ 34 "Acid" }
|
||||
{ 35 "House" }
|
||||
{ 36 "Game" }
|
||||
{ 37 "Sound Clip" }
|
||||
{ 38 "Gospel" }
|
||||
{ 39 "Noise" }
|
||||
{ 40 "AlternRock" }
|
||||
{ 41 "Bass" }
|
||||
{ 42 "Soul" }
|
||||
{ 43 "Punk" }
|
||||
{ 44 "Space" }
|
||||
{ 45 "Meditative" }
|
||||
{ 46 "Instrumental Pop" }
|
||||
{ 47 "Instrumental Rock" }
|
||||
{ 48 "Ethnic" }
|
||||
{ 49 "Gothic" }
|
||||
{ 50 "Darkwave" }
|
||||
{ 51 "Techno-Industrial" }
|
||||
{ 52 "Electronic" }
|
||||
{ 53 "Pop-Folk" }
|
||||
{ 54 "Eurodance" }
|
||||
{ 55 "Dream" }
|
||||
{ 56 "Southern Rock" }
|
||||
{ 57 "Comedy" }
|
||||
{ 58 "Cult" }
|
||||
{ 59 "Gangsta" }
|
||||
{ 60 "Top 40" }
|
||||
{ 61 "Christian Rap" }
|
||||
{ 62 "Pop/Funk" }
|
||||
{ 63 "Jungle" }
|
||||
{ 64 "Native American" }
|
||||
{ 65 "Cabaret" }
|
||||
{ 66 "New Wave" }
|
||||
{ 67 "Psychedelic" }
|
||||
{ 68 "Rave" }
|
||||
{ 69 "Showtunes" }
|
||||
{ 70 "Trailer" }
|
||||
{ 71 "Lo-Fi" }
|
||||
{ 72 "Tribal" }
|
||||
{ 73 "Acid Punk" }
|
||||
{ 74 "Acid Jazz" }
|
||||
{ 75 "Polka" }
|
||||
{ 76 "Retro" }
|
||||
{ 77 "Musical" }
|
||||
{ 78 "Rock & Roll" }
|
||||
{ 79 "Hard Rock" }
|
||||
{ 80 "Folk" }
|
||||
{ 81 "Folk-Rock" }
|
||||
{ 82 "National Folk" }
|
||||
{ 83 "Swing" }
|
||||
{ 84 "Fast Fusion" }
|
||||
{ 85 "Bebop" }
|
||||
{ 86 "Latin" }
|
||||
{ 87 "Revival" }
|
||||
{ 88 "Celtic" }
|
||||
{ 89 "Bluegrass" }
|
||||
{ 90 "Avantgarde" }
|
||||
{ 91 "Gothic Rock" }
|
||||
{ 92 "Progressive Rock" }
|
||||
{ 93 "Psychedelic Rock" }
|
||||
{ 94 "Symphonic Rock" }
|
||||
{ 95 "Slow Rock" }
|
||||
{ 96 "Big Band" }
|
||||
{ 97 "Chorus" }
|
||||
{ 98 "Easy Listening" }
|
||||
{ 99 "Acoustic" }
|
||||
{ 100 "Humour" }
|
||||
{ 101 "Speech" }
|
||||
{ 102 "Chanson" }
|
||||
{ 103 "Opera" }
|
||||
{ 104 "Chamber Music" }
|
||||
{ 105 "Sonata" }
|
||||
{ 106 "Symphony" }
|
||||
{ 107 "Booty Bass" }
|
||||
{ 108 "Primus" }
|
||||
{ 109 "Porn Groove" }
|
||||
{ 110 "Satire" }
|
||||
{ 111 "Slow Jam" }
|
||||
{ 112 "Club" }
|
||||
{ 113 "Tango" }
|
||||
{ 114 "Samba" }
|
||||
{ 115 "Folklore" }
|
||||
{ 116 "Ballad" }
|
||||
{ 117 "Power Ballad" }
|
||||
{ 118 "Rhythmic Soul" }
|
||||
{ 119 "Freestyle" }
|
||||
{ 120 "Duet" }
|
||||
{ 121 "Punk Rock" }
|
||||
{ 122 "Drum Solo" }
|
||||
{ 123 "A capella" }
|
||||
{ 124 "Euro-House" }
|
||||
{ 125 "Dance Hall" }
|
||||
} ! end genre hashtable
|
||||
|
||||
! tuples
|
||||
|
||||
TUPLE: header version flags size ;
|
||||
|
||||
TUPLE: frame frame-id flags size data ;
|
||||
|
||||
TUPLE: mp3v2-file header frames ;
|
||||
TUPLE: id3v2-info header frames ;
|
||||
|
||||
TUPLE: mp3v1-file title artist album year comment genre ;
|
||||
TUPLE: id3-info title artist album year comment genre ;
|
||||
|
||||
: <mp3v1-file> ( -- object ) mp3v1-file new ;
|
||||
: <id3-info> ( -- object ) id3-info new ;
|
||||
|
||||
: <mp3v2-file> ( header frames -- object ) mp3v2-file boa ;
|
||||
: <id3v2-info> ( header frames -- object ) id3v2-info boa ;
|
||||
|
||||
: <header> ( -- object ) header new ;
|
||||
|
||||
: <frame> ( -- object ) frame new ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! utility words
|
||||
|
||||
: id3v2? ( mmap -- ? )
|
||||
|
|
@ -59,10 +190,10 @@ TUPLE: mp3v1-file title artist album year comment genre ;
|
|||
: (read-frame) ( mmap -- frame )
|
||||
[ <frame> ] dip
|
||||
{
|
||||
[ read-frame-id ascii decode >>frame-id ]
|
||||
[ read-frame-id utf8 decode >>frame-id ]
|
||||
[ read-frame-flags >byte-array >>flags ]
|
||||
[ read-frame-size >28bitword >>size ]
|
||||
[ read-frame-data ascii decode >>data ]
|
||||
[ read-frame-data utf8 decode >>data ]
|
||||
} cleave ;
|
||||
|
||||
: read-frame ( mmap -- frame/f )
|
||||
|
|
@ -98,9 +229,21 @@ TUPLE: mp3v1-file title artist album year comment genre ;
|
|||
: drop-header ( mmap -- seq1 seq2 )
|
||||
dup 10 tail-slice swap ;
|
||||
|
||||
: read-v2-tag-data ( seq -- mp3v2-file )
|
||||
drop-header read-v2-header swap read-frames <mp3v2-file> ;
|
||||
: parse-frames ( id3v2-info -- id3-info )
|
||||
[ <id3-info> ] dip frames>>
|
||||
{
|
||||
[ [ frame-id>> "TIT2" = ] find nip [ data>> >>title ] when* ]
|
||||
[ [ frame-id>> "TALB" = ] find nip [ data>> >>album ] when* ]
|
||||
[ [ frame-id>> "TPE1" = ] find nip [ data>> >>artist ] when* ]
|
||||
[ [ frame-id>> "TCON" = ] find nip [ data>> [ [ digit? ] filter string>number ] keep swap [ genres at nip ] when*
|
||||
>>genre ] when* ]
|
||||
[ [ frame-id>> "COMM" = ] find nip [ data>> >>comment ] when* ]
|
||||
[ [ frame-id>> "TYER" = ] find nip [ data>> >>year ] when* ]
|
||||
} cleave ;
|
||||
|
||||
: read-v2-tag-data ( seq -- id3-info )
|
||||
drop-header read-v2-header swap read-frames <id3v2-info> parse-frames ;
|
||||
|
||||
! v1 information
|
||||
|
||||
: skip-to-v1-data ( seq -- seq )
|
||||
|
|
@ -125,14 +268,14 @@ TUPLE: mp3v1-file title artist album year comment genre ;
|
|||
[ 124 ] dip nth ;
|
||||
|
||||
: (read-v1-tag-data) ( seq -- mp3-file )
|
||||
[ <mp3v1-file> ] dip
|
||||
[ <id3-info> ] dip
|
||||
{
|
||||
[ read-title ascii decode filter-text-data >>title ]
|
||||
[ read-artist ascii decode filter-text-data >>artist ]
|
||||
[ read-album ascii decode filter-text-data >>album ]
|
||||
[ read-year ascii decode filter-text-data >>year ]
|
||||
[ read-comment ascii decode filter-text-data >>comment ]
|
||||
[ read-genre >fixnum >>genre ]
|
||||
[ read-title utf8 decode filter-text-data >>title ]
|
||||
[ read-artist utf8 decode filter-text-data >>artist ]
|
||||
[ read-album utf8 decode filter-text-data >>album ]
|
||||
[ read-year utf8 decode filter-text-data >>year ]
|
||||
[ read-comment utf8 decode filter-text-data >>comment ]
|
||||
[ read-genre >fixnum genres at >>genre ]
|
||||
} cleave ;
|
||||
|
||||
: read-v1-tag-data ( seq -- mp3-file )
|
||||
|
|
@ -140,13 +283,13 @@ TUPLE: mp3v1-file title artist album year comment genre ;
|
|||
|
||||
PRIVATE>
|
||||
|
||||
! main stuff
|
||||
! public interface
|
||||
|
||||
: file-id3-tags ( path -- object/f )
|
||||
[
|
||||
{
|
||||
{ [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file )
|
||||
{ [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- mp3v1-file )
|
||||
{ [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- id3v2 )
|
||||
{ [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- id3-info )
|
||||
[ drop f ] ! ( mmap -- f )
|
||||
} cond
|
||||
] with-mapped-uchar-file ;
|
||||
|
|
|
|||
|
|
@ -1,19 +1,19 @@
|
|||
! Copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax multiline ;
|
||||
USING: help.markup help.syntax kernel multiline ;
|
||||
IN: literals
|
||||
|
||||
HELP: $
|
||||
{ $syntax "$ word" }
|
||||
{ $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." }
|
||||
{ $notes "Since " { $snippet "word" } " is executed at parse time, " { $snippet "$" } " cannot be used with words defined in the same compilation unit." }
|
||||
{ $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
|
||||
{ $examples
|
||||
|
||||
{ $example <"
|
||||
USING: kernel literals prettyprint ;
|
||||
IN: scratchpad
|
||||
|
||||
<< : five 5 ; >>
|
||||
CONSTANT: five 5
|
||||
{ $ five } .
|
||||
"> "{ 5 }" }
|
||||
|
||||
|
|
@ -30,7 +30,7 @@ IN: scratchpad
|
|||
HELP: $[
|
||||
{ $syntax "$[ code ]" }
|
||||
{ $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." }
|
||||
{ $notes "Since " { $snippet "code" } " is executed at parse time, it cannot reference any words defined in the same compilation unit." }
|
||||
{ $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." }
|
||||
{ $examples
|
||||
|
||||
{ $example <"
|
||||
|
|
|
|||
|
|
@ -2,11 +2,12 @@ USING: kernel literals math tools.test ;
|
|||
IN: literals.tests
|
||||
|
||||
<<
|
||||
: five 5 ;
|
||||
: seven-eleven 7 11 ;
|
||||
: six-six-six 6 6 6 ;
|
||||
>>
|
||||
|
||||
: five 5 ;
|
||||
: seven-eleven 7 11 ;
|
||||
|
||||
[ { 5 } ] [ { $ five } ] unit-test
|
||||
[ { 7 11 } ] [ { $ seven-eleven } ] unit-test
|
||||
[ { 6 6 6 } ] [ { $ six-six-six } ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! (c) Joe Groff, see license for details
|
||||
USING: continuations kernel parser words quotations vectors ;
|
||||
USING: accessors continuations kernel parser words quotations vectors ;
|
||||
IN: literals
|
||||
|
||||
: $ scan-word [ execute ] curry with-datastack >vector ; parsing
|
||||
: $ scan-word [ def>> call ] curry with-datastack >vector ; parsing
|
||||
: $[ \ ] parse-until >quotation with-datastack >vector ; parsing
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Jason W. Merrill
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
! Copyright (C) 2009 Jason W. Merrill.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax ;
|
||||
IN: math.derivatives
|
||||
|
||||
ARTICLE: "math.derivatives" "Derivatives"
|
||||
"The " { $vocab-link "math.derivatives" } " vocabulary defines the derivative of many of the words in the " { $vocab-link "math" } " and " { $vocab-link "math.functions" } " vocabularies. The derivative for a word is given by a sequence of quotations stored in its " { $snippet "derivative" } " word property that give the partial derivative of the word with respect to each of its inputs."
|
||||
{ $see-also "math.derivatives.syntax" }
|
||||
;
|
||||
|
||||
ABOUT: "math.derivatives"
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2009 Jason W. Merrill.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test automatic-differentiation.derivatives ;
|
||||
IN: automatic-differentiation.derivatives.tests
|
||||
|
|
@ -0,0 +1,53 @@
|
|||
! Copyright (C) 2009 Jason W. Merrill.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.functions math.derivatives.syntax
|
||||
math.order math.parser summary accessors make combinators ;
|
||||
IN: math.derivatives
|
||||
|
||||
ERROR: undefined-derivative point word ;
|
||||
M: undefined-derivative summary
|
||||
[ dup "Derivative of " % word>> name>> %
|
||||
" is undefined at " % point>> # "." % ]
|
||||
"" make ;
|
||||
|
||||
DERIVATIVE: + [ 2drop ] [ 2drop ]
|
||||
DERIVATIVE: - [ 2drop ] [ 2drop neg ]
|
||||
DERIVATIVE: * [ nip * ] [ drop * ]
|
||||
DERIVATIVE: / [ nip / ] [ sq / neg * ]
|
||||
! Conditional checks if the epsilon-part of the exponent is
|
||||
! 0 to avoid getting float answers for integer powers.
|
||||
DERIVATIVE: ^ [ [ 1 - ^ ] keep * * ]
|
||||
[ [ dup zero? ] 2dip [ 3drop 0 ] [ [ ^ ] keep log * * ] if ]
|
||||
|
||||
DERIVATIVE: abs
|
||||
[ 0 <=>
|
||||
{
|
||||
{ +lt+ [ neg ] }
|
||||
{ +eq+ [ 0 \ abs undefined-derivative ] }
|
||||
{ +gt+ [ ] }
|
||||
} case
|
||||
]
|
||||
|
||||
DERIVATIVE: sqrt [ sqrt 2 * / ]
|
||||
|
||||
DERIVATIVE: exp [ exp * ]
|
||||
DERIVATIVE: log [ / ]
|
||||
|
||||
DERIVATIVE: sin [ cos * ]
|
||||
DERIVATIVE: cos [ sin neg * ]
|
||||
DERIVATIVE: tan [ sec sq * ]
|
||||
|
||||
DERIVATIVE: sinh [ cosh * ]
|
||||
DERIVATIVE: cosh [ sinh * ]
|
||||
DERIVATIVE: tanh [ sech sq * ]
|
||||
|
||||
DERIVATIVE: asin [ sq neg 1 + sqrt / ]
|
||||
DERIVATIVE: acos [ sq neg 1 + sqrt neg / ]
|
||||
DERIVATIVE: atan [ sq 1 + / ]
|
||||
|
||||
DERIVATIVE: asinh [ sq 1 + sqrt / ]
|
||||
DERIVATIVE: acosh [ [ 1 + sqrt ] [ 1 - sqrt ] bi * / ]
|
||||
DERIVATIVE: atanh [ sq neg 1 + / ]
|
||||
|
||||
DERIVATIVE: neg [ drop neg ]
|
||||
DERIVATIVE: recip [ sq recip neg * ]
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jason W. Merrill
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
! Copyright (C) 2009 Jason W. Merrill.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax ;
|
||||
IN: math.derivatives.syntax
|
||||
|
||||
HELP: DERIVATIVE:
|
||||
{ $description "Defines the derivative of a word by setting its " { $snippet "derivative" } " word property. Reads a word followed by " { $snippet "n" } " quotations, giving the " { $snippet "n" } " partial derivatives of the word with respect to each of its arguments successively. Each quotation should take " { $snippet "n + 1" } " inputs, where the first input is an increment and the last " { $snippet "n" } " inputs are the point at which to evaluate the derivative. The derivative should be a linear function of the increment, and should have the same number of outputs as the original word." }
|
||||
{ $examples
|
||||
{ $unchecked-example "USING: math math.functions math.derivatives.syntax ;"
|
||||
"DERIVATIVE: sin [ cos * ]"
|
||||
"DERIVATIVE: * [ nip * ] [ drop * ]" "" }
|
||||
} ;
|
||||
|
||||
ARTICLE: "math.derivatives.syntax" "Derivative Syntax"
|
||||
"The " { $vocab-link "math.derivatives.syntax" } " vocabulary provides the " { $link POSTPONE: DERIVATIVE: } " syntax for specifying the derivative of a word."
|
||||
;
|
||||
|
||||
ABOUT: "math.derivatives.syntax"
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
! Copyright (C) 2009 Jason W. Merrill.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel parser words effects accessors sequences
|
||||
math.ranges ;
|
||||
|
||||
IN: math.derivatives.syntax
|
||||
|
||||
: DERIVATIVE: scan-object dup stack-effect in>> length [1,b]
|
||||
[ drop scan-object ] map
|
||||
"derivative" set-word-prop ; parsing
|
||||
|
|
@ -0,0 +1 @@
|
|||
Jason W. Merrill
|
||||
|
|
@ -0,0 +1,132 @@
|
|||
! Copyright (C) 2009 Jason W. Merrill.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel words math math.functions math.derivatives.syntax ;
|
||||
IN: math.dual
|
||||
|
||||
HELP: <dual>
|
||||
{ $values
|
||||
{ "ordinary-part" real } { "epsilon-part" real }
|
||||
{ "dual" dual number }
|
||||
}
|
||||
{ $description "Creates a dual number from its ordinary and epsilon parts." } ;
|
||||
|
||||
HELP: d*
|
||||
{ $values
|
||||
{ "x" dual } { "y" dual }
|
||||
{ "x*y" dual }
|
||||
}
|
||||
{ $description "Multiply dual numbers." } ;
|
||||
|
||||
HELP: d+
|
||||
{ $values
|
||||
{ "x" dual } { "y" dual }
|
||||
{ "x+y" dual }
|
||||
}
|
||||
{ $description "Add dual numbers." } ;
|
||||
|
||||
HELP: d-
|
||||
{ $values
|
||||
{ "x" dual } { "y" dual }
|
||||
{ "x-y" dual }
|
||||
}
|
||||
{ $description "Subtract dual numbers." } ;
|
||||
|
||||
HELP: d/
|
||||
{ $values
|
||||
{ "x" dual } { "y" dual }
|
||||
{ "x/y" dual }
|
||||
}
|
||||
{ $description "Divide dual numbers." }
|
||||
{ $errors "Throws an error if the ordinary part of " { $snippet "x" } " is zero." } ;
|
||||
|
||||
HELP: d^
|
||||
{ $values
|
||||
{ "x" dual } { "y" dual }
|
||||
{ "x^y" dual }
|
||||
}
|
||||
{ $description "Raise a dual number to a (possibly dual) power" } ;
|
||||
|
||||
HELP: dabs
|
||||
{ $values
|
||||
{ "x" dual }
|
||||
{ "|x|" dual }
|
||||
}
|
||||
{ $description "Absolute value of a dual number." } ;
|
||||
|
||||
HELP: dacosh
|
||||
{ $values
|
||||
{ "x" dual }
|
||||
{ "y" dual }
|
||||
}
|
||||
{ $description "Inverse hyberbolic cosine of a dual number." } ;
|
||||
|
||||
HELP: dasinh
|
||||
{ $values
|
||||
{ "x" dual }
|
||||
{ "y" dual }
|
||||
}
|
||||
{ $description "Inverse hyberbolic sine of a dual number." } ;
|
||||
|
||||
HELP: datanh
|
||||
{ $values
|
||||
{ "x" dual }
|
||||
{ "y" dual }
|
||||
}
|
||||
{ $description "Inverse hyberbolic tangent of a dual number." } ;
|
||||
|
||||
HELP: dneg
|
||||
{ $values
|
||||
{ "x" dual }
|
||||
{ "-x" dual }
|
||||
}
|
||||
{ $description "Negative of a dual number." } ;
|
||||
|
||||
HELP: drecip
|
||||
{ $values
|
||||
{ "x" dual }
|
||||
{ "1/x" dual }
|
||||
}
|
||||
{ $description "Reciprocal of a dual number." } ;
|
||||
|
||||
HELP: define-dual-method
|
||||
{ $values
|
||||
{ "word" word }
|
||||
}
|
||||
{ $description "Defines a method on the dual numbers for generic word." }
|
||||
{ $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments. This can be set using " { $link POSTPONE: DERIVATIVE: } "." } ;
|
||||
|
||||
{ define-dual-method dual-op POSTPONE: DERIVATIVE: } related-words
|
||||
|
||||
HELP: dual
|
||||
{ $class-description "The class of dual numbers with non-zero epsilon part." } ;
|
||||
|
||||
HELP: dual-op
|
||||
{ $values
|
||||
{ "word" word }
|
||||
}
|
||||
{ $description "Similar to " { $link execute } ", but promotes word to operate on duals." }
|
||||
{ $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments. This can be set using " { $link POSTPONE: DERIVATIVE: } ". Once a derivative has been defined for a word, dual-op makes it easy to extend the definition to dual numbers." }
|
||||
{ $examples
|
||||
{ $unchecked-example "USING: math math.dual math.derivatives.syntax math.functions ;"
|
||||
"DERIVATIVE: sin [ cos * ]"
|
||||
"M: dual sin \\sin dual-op ;" "" }
|
||||
{ $unchecked-example "USING: math math.dual math.derivatives.syntax ;"
|
||||
"DERIVATIVE: * [ drop ] [ nip ]"
|
||||
": d* ( x y -- x*y ) \ * dual-op ;" "" }
|
||||
} ;
|
||||
|
||||
HELP: unpack-dual
|
||||
{ $values
|
||||
{ "dual" dual }
|
||||
{ "ordinary-part" number } { "epsilon-part" number }
|
||||
}
|
||||
{ $description "Extracts the ordinary and epsilon part of a dual number." } ;
|
||||
|
||||
ARTICLE: "math.dual" "Dual Numbers"
|
||||
"The " { $vocab-link "math.dual" } " vocabulary implements dual numbers, along with arithmetic methods for working with them. Many of the functions in " { $vocab-link "math.functions" } " are extended to work with dual numbers."
|
||||
$nl
|
||||
"Dual numbers are ordered pairs " { $snippet "<o,e>"} "--an ordinary part and an epsilon part--with component-wise addition and multiplication defined by "{ $snippet "<o1,e1>*<o2,e2> = <o1*o2,e1*o2 + e2*o1>" } ". They are analagous to complex numbers with " { $snippet "i^2 = 0" } "instead of " { $snippet "i^2 = -1" } ". For well-behaved functions " { $snippet "f" } ", " { $snippet "f(<o1,e1>) = f(o1) + e1*f'(o1)" } ", where " { $snippet "f'"} " is the derivative of " { $snippet "f" } "."
|
||||
;
|
||||
|
||||
|
||||
ABOUT: "math.dual"
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2009 Jason W. Merrill.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test math.dual kernel accessors math math.functions
|
||||
math.constants ;
|
||||
IN: math.dual.tests
|
||||
|
||||
[ 0.0 1.0 ] [ 0 1 <dual> sin unpack-dual ] unit-test
|
||||
[ 1.0 0.0 ] [ 0 1 <dual> cos unpack-dual ] unit-test
|
||||
[ 3 5 ] [ 1 5 <dual> 2 d+ unpack-dual ] unit-test
|
||||
[ 0 -1 ] [ 1 5 <dual> 1 6 <dual> d- unpack-dual ] unit-test
|
||||
[ 2 1 ] [ 2 3 <dual> 1 -1 <dual> d* unpack-dual ] unit-test
|
||||
[ 1/2 -1/4 ] [ 2 1 <dual> 1 swap d/ unpack-dual ] unit-test
|
||||
[ 2 ] [ 1 1 <dual> 2 d^ epsilon-part>> ] unit-test
|
||||
[ 2.0 .25 ] [ 4 1 <dual> sqrt unpack-dual ] unit-test
|
||||
[ 2 -1 ] [ -2 1 <dual> dabs unpack-dual ] unit-test
|
||||
[ -2 -1 ] [ 2 1 <dual> dneg unpack-dual ] unit-test
|
||||
|
|
@ -0,0 +1,92 @@
|
|||
! Copyright (C) 2009 Jason W. Merrill.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.functions math.derivatives accessors
|
||||
macros words effects sequences generalizations fry
|
||||
combinators.smart generic compiler.units ;
|
||||
|
||||
IN: math.dual
|
||||
|
||||
TUPLE: dual ordinary-part epsilon-part ;
|
||||
|
||||
C: <dual> dual
|
||||
|
||||
! Ordinary numbers implement the dual protocol by returning
|
||||
! themselves as the ordinary part, and 0 as the epsilon part.
|
||||
M: number ordinary-part>> ;
|
||||
|
||||
M: number epsilon-part>> drop 0 ;
|
||||
|
||||
: unpack-dual ( dual -- ordinary-part epsilon-part )
|
||||
[ ordinary-part>> ] [ epsilon-part>> ] bi ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: input-length ( word -- n ) stack-effect in>> length ;
|
||||
|
||||
MACRO: ordinary-op ( word -- o )
|
||||
[ input-length ] keep
|
||||
'[ [ ordinary-part>> ] _ napply _ execute ] ;
|
||||
|
||||
! Takes N dual numbers <o1,e1> <o2,e2> ... <oN,eN> and weaves
|
||||
! their ordinary and epsilon parts to produce
|
||||
! e1 o1 o2 ... oN e2 o1 o2 ... oN ... eN o1 o2 ... oN
|
||||
! This allows a set of partial derivatives each to be evaluated
|
||||
! at the same point.
|
||||
MACRO: duals>nweave ( n -- )
|
||||
dup dup dup
|
||||
'[
|
||||
[ [ epsilon-part>> ] _ napply ]
|
||||
_ nkeep
|
||||
[ ordinary-part>> ] _ napply
|
||||
_ nweave
|
||||
] ;
|
||||
|
||||
MACRO: chain-rule ( word -- e )
|
||||
[ input-length '[ _ duals>nweave ] ]
|
||||
[ "derivative" word-prop ]
|
||||
[ input-length 1+ '[ _ nspread ] ]
|
||||
tri
|
||||
'[ [ @ _ @ ] sum-outputs ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: dual-op ( word -- )
|
||||
[ '[ _ ordinary-op ] ]
|
||||
[ input-length '[ _ nkeep ] ]
|
||||
[ '[ _ chain-rule ] ]
|
||||
tri
|
||||
'[ _ @ @ <dual> ] ;
|
||||
|
||||
: define-dual-method ( word -- )
|
||||
[ \ dual swap create-method ] keep '[ _ dual-op ] define ;
|
||||
|
||||
! Specialize math functions to operate on dual numbers.
|
||||
[ { sqrt exp log sin cos tan sinh cosh tanh acos asin atan }
|
||||
[ define-dual-method ] each ] with-compilation-unit
|
||||
|
||||
! Inverse methods { asinh, acosh, atanh } are not generic, so
|
||||
! there is no way to specialize them for dual numbers. However,
|
||||
! they are defined in terms of functions that can operate on
|
||||
! dual numbers and arithmetic methods, so if it becomes
|
||||
! possible to make arithmetic operators work directly on dual
|
||||
! numbers, we will get these for free.
|
||||
|
||||
! Arithmetic words are not generic (yet?), so we have to
|
||||
! define special versions of them to operate on dual numbers.
|
||||
: d+ ( x y -- x+y ) \ + dual-op ;
|
||||
: d- ( x y -- x-y ) \ - dual-op ;
|
||||
: d* ( x y -- x*y ) \ * dual-op ;
|
||||
: d/ ( x y -- x/y ) \ / dual-op ;
|
||||
: d^ ( x y -- x^y ) \ ^ dual-op ;
|
||||
|
||||
: dabs ( x -- |x| ) \ abs dual-op ;
|
||||
|
||||
! The following words are also not generic, but are defined in
|
||||
! terms of words that can operate on dual numbers and
|
||||
! arithmetic. If it becomes possible to implement arithmetic on
|
||||
! dual numbers directly, these functions can be deleted.
|
||||
: dneg ( x -- -x ) \ neg dual-op ;
|
||||
: drecip ( x -- 1/x ) \ recip dual-op ;
|
||||
: dasinh ( x -- y ) \ asinh dual-op ;
|
||||
: dacosh ( x -- y ) \ acosh dual-op ;
|
||||
: datanh ( x -- y ) \ atanh dual-op ;
|
||||
|
|
@ -111,6 +111,7 @@ beast.
|
|||
| C-cC-ev | edit vocabulary (fuel-edit-vocabulary) |
|
||||
| C-cC-ew | edit word (fuel-edit-word-at-point) |
|
||||
| C-cC-ed | edit word's doc (C-u M-x fuel-edit-word-doc-at-point) |
|
||||
| C-cC-el | load vocabs in USING: form |
|
||||
|-----------------+------------------------------------------------------------|
|
||||
| C-cC-er | eval region |
|
||||
| C-M-r, C-cC-ee | eval region, extending it to definition boundaries |
|
||||
|
|
|
|||
|
|
@ -32,6 +32,22 @@
|
|||
:type 'boolean)
|
||||
|
||||
|
||||
(defcustom fuel-autodoc-eval-using-form-p nil
|
||||
"When enabled, automatically load vocabularies in USING: form
|
||||
to display autodoc messages.
|
||||
|
||||
In order to show autodoc messages for words in a Factor buffer,
|
||||
the used vocabularies must be loaded in the Factor image. Setting
|
||||
this variable to `t' will do that automatically for you,
|
||||
asynchronously. That means that you'll be able to move around
|
||||
while the vocabs are being loaded, but no other FUEL
|
||||
functionality will be available until loading finishes (and it
|
||||
may take a while). Thus, this functionality is disabled by
|
||||
default. You can force loading the vocabs in a Factor buffer
|
||||
USING: form with \\[fuel-load-usings]."
|
||||
:group 'fuel-autodoc
|
||||
:type 'boolean)
|
||||
|
||||
|
||||
;;; Eldoc function:
|
||||
|
||||
|
|
@ -41,9 +57,10 @@
|
|||
(let ((word (or word (fuel-syntax-symbol-at-point)))
|
||||
(fuel-log--inhibit-p t))
|
||||
(when word
|
||||
(let* ((cmd (if (fuel-syntax--in-using)
|
||||
(let* ((usings (if fuel-autodoc-eval-using-form-p :usings t))
|
||||
(cmd (if (fuel-syntax--in-using)
|
||||
`(:fuel* (,word fuel-vocab-summary) :in t)
|
||||
`(:fuel* (((:quote ,word) synopsis :get)) :in)))
|
||||
`(:fuel* ((,word :usings fuel-word-synopsis)) t ,usings)))
|
||||
(ret (fuel-eval--send/wait cmd fuel-autodoc--timeout))
|
||||
(res (fuel-eval--retort-result ret)))
|
||||
(when (and ret (not (fuel-eval--retort-error ret)) (stringp res))
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@
|
|||
(t (error "Invalid 'in' (%s)" in))))
|
||||
|
||||
(defsubst factor--fuel-usings (usings)
|
||||
(cond ((null usings) :usings)
|
||||
(cond ((or (null usings) (eq usings :usings)) :usings)
|
||||
((eq usings t) nil)
|
||||
((listp usings) `(:array ,@usings))
|
||||
(t (error "Invalid 'usings' (%s)" usings))))
|
||||
|
|
|
|||
|
|
@ -132,6 +132,18 @@ With prefix argument, ask for the file name."
|
|||
(let ((file (car (fuel-mode--read-file arg))))
|
||||
(when file (fuel-debug--uses-for-file file))))
|
||||
|
||||
(defun fuel-load-usings ()
|
||||
"Loads all vocabularies in the current buffer's USING: from.
|
||||
Useful to activate autodoc help messages in a vocabulary not yet
|
||||
loaded. See documentation for `fuel-autodoc-eval-using-form-p'
|
||||
for details."
|
||||
(interactive)
|
||||
(message "Loading all vocabularies in USING: form ...")
|
||||
(let ((err (fuel-eval--retort-error
|
||||
(fuel-eval--send/wait '(:fuel* (t) t :usings) 120000))))
|
||||
(message (if err "Warning: some vocabularies failed to load"
|
||||
"All vocabularies loaded"))))
|
||||
|
||||
|
||||
;;; Minor mode definition:
|
||||
|
||||
|
|
@ -191,7 +203,8 @@ interacting with a factor listener is at your disposal.
|
|||
|
||||
(fuel-mode--key ?e ?d 'fuel-edit-word-doc-at-point)
|
||||
(fuel-mode--key ?e ?e 'fuel-eval-extended-region)
|
||||
(fuel-mode--key ?e ?l 'fuel-run-file)
|
||||
(fuel-mode--key ?e ?k 'fuel-run-file)
|
||||
(fuel-mode--key ?e ?l 'fuel-load-usings)
|
||||
(fuel-mode--key ?e ?r 'fuel-eval-region)
|
||||
(fuel-mode--key ?e ?u 'fuel-update-usings)
|
||||
(fuel-mode--key ?e ?v 'fuel-edit-vocabulary)
|
||||
|
|
|
|||
Loading…
Reference in New Issue