[ f ] [ "test-blah" resource-path exists? ] unit-test
- [ ] [ "test-quux.txt" resource-path ascii [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test
-[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
++[ ] [ "test-quux.txt" resource-path ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
[ ] [ "test-quux.txt" resource-path delete-file ] unit-test
- [ ] [ "test-quux.txt" resource-path ascii [ [ yield "Hi" write ] in-thread ] with-file-writer ] unit-test
-[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
++[ ] [ "test-quux.txt" resource-path ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
[ ] [ "test-quux.txt" "quux-test.txt" [ resource-path ] 2apply rename-file ] unit-test
[ t ] [ "quux-test.txt" resource-path exists? ] unit-test
M: pathname <=> [ pathname-string ] compare ;
-: file-lines ( path -- seq ) <file-reader> lines ;
+: file-lines ( path encoding -- seq ) <file-reader> lines ;
-: file-contents ( path -- str )
- dup <file-reader> swap file-length <sbuf>
+: file-contents ( path encoding -- str )
- dupd <file-reader> swap file-length <sbuf> [ stream-copy ] keep >string ;
++ dupd <file-reader> swap file-length <sbuf>
+ [ stream-copy ] keep >string ;
- : with-file-writer ( path encoding quot -- )
- >r <file-writer> r> with-stream ; inline
-
- : with-file-reader ( path encoding quot -- )
+ : with-file-reader ( path quot -- )
>r <file-reader> r> with-stream ; inline
-: with-file-appender ( path quot -- )
+ : with-file-writer ( path quot -- )
+ >r <file-writer> r> with-stream ; inline
+
+: with-file-appender ( path encoding quot -- )
>r <file-appender> r> with-stream ; inline
USING: io io.files io.streams.duplex kernel sequences
sequences.private strings vectors words memoize splitting
- hints unicode.case io.encodings.latin1 ;
-hints unicode.case continuations ;
++hints unicode.case continuations io.encodings.latin1 ;
IN: benchmark.reverse-complement
MEMO: trans-map ( -- str )
readln [ do-line (reverse-complement) ] [ show-seq ] if* ;
: reverse-complement ( infile outfile -- )
- latin1 <file-writer> >r latin1 <file-reader> r> <duplex-stream> [
- 500000 <vector> (reverse-complement)
- ] with-stream ;
- <file-writer> [
- swap <file-reader> [
++ latin1 <file-writer> [
++ swap latin1 <file-reader> [
+ swap <duplex-stream> [
+ 500000 <vector> (reverse-complement)
+ ] with-stream
+ ] with-disposal
+ ] with-disposal ;
: reverse-complement-in
"extra/benchmark/reverse-complement/reverse-complement-in.txt"
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
- USING: kernel math sequences words arrays io
- io.files namespaces math.parser kernel.private
- assocs quotations parser parser-combinators tools.time
- sequences.private compiler.units io.encodings.binary ;
+ USING: kernel math sequences words arrays io io.files namespaces
+ math.parser assocs quotations parser parser-combinators
-tools.time ;
++tools.time io.encodings.binary ;
IN: cpu.8080.emulator
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
- USING: io.files io.sockets io kernel threads namespaces
- tools.test continuations strings byte-arrays sequences
- prettyprint system io.encodings.binary io.encodings.ascii ;
+ USING: io.files io.sockets io kernel threads
+ namespaces tools.test continuations strings byte-arrays
-sequences prettyprint system ;
++sequences prettyprint system io.encodings.binary io.encodings.ascii ;
IN: temporary
! Unix domain stream sockets
--! Copyright (C) 2008 Slava Pestov.\r
--! See http://factorcode.org/license.txt for BSD license.\r
--USING: namespaces kernel io calendar sequences io.files\r
--io.sockets continuations prettyprint assocs math.parser\r
- words debugger math combinators concurrency arrays init\r
- math.ranges strings io.encodings.utf8 ;\r
-words debugger math combinators concurrency.messaging\r
-threads arrays init math.ranges strings ;\r
--IN: logging.server\r
--\r
--: log-root ( -- string )\r
-- \ log-root get "logs" resource-path or ;\r
--\r
--: log-path ( service -- path )\r
-- log-root swap path+ ;\r
--\r
--: log# ( path n -- path' )\r
-- number>string ".log" append path+ ;\r
--\r
--SYMBOL: log-files\r
--\r
--: open-log-stream ( service -- stream )\r
-- log-path\r
-- dup make-directories\r
- 1 log# utf8 <file-appender> ;\r
- 1 log# <file-appender> ;\r
--\r
--: log-stream ( service -- stream )\r
-- log-files get [ open-log-stream ] cache ;\r
--\r
--: multiline-header 20 CHAR: - <string> ; foldable\r
--\r
--: (write-message) ( msg word-name level multi? -- )\r
-- [\r
-- "[" write multiline-header write "] " write\r
-- ] [\r
-- "[" write now (timestamp>rfc3339) "] " write\r
-- ] if\r
-- write bl write ": " write print ;\r
--\r
--: write-message ( msg word-name level -- )\r
-- rot [ empty? not ] subset {\r
-- { [ dup empty? ] [ 3drop ] }\r
-- { [ dup length 1 = ] [ first -rot f (write-message) ] }\r
-- { [ t ] [\r
-- [ first -rot f (write-message) ] 3keep\r
-- 1 tail -rot [ t (write-message) ] 2curry each\r
-- ] }\r
-- } cond ;\r
--\r
--: (log-message) ( msg -- )\r
-- #! msg: { msg word-name level service }\r
-- first4 log-stream [ write-message flush ] with-stream* ;\r
--\r
--: try-dispose ( stream -- )\r
-- [ dispose ] curry [ error. ] recover ;\r
--\r
--: close-log ( service -- )\r
-- log-files get delete-at*\r
-- [ try-dispose ] [ drop ] if ;\r
--\r
--: (close-logs) ( -- )\r
-- log-files get\r
-- dup values [ try-dispose ] each\r
-- clear-assoc ;\r
--\r
--: keep-logs 10 ;\r
--\r
--: ?delete-file ( path -- )\r
-- dup exists? [ delete-file ] [ drop ] if ;\r
--\r
--: delete-oldest keep-logs log# ?delete-file ;\r
--\r
--: ?rename-file ( old new -- )\r
-- over exists? [ rename-file ] [ 2drop ] if ;\r
--\r
--: advance-log ( path n -- )\r
-- [ 1- log# ] 2keep log# ?rename-file ;\r
--\r
--: rotate-log ( service -- )\r
-- dup close-log\r
-- log-path\r
-- dup delete-oldest\r
-- keep-logs 1 [a,b] [ advance-log ] with each ;\r
--\r
--: (rotate-logs) ( -- )\r
-- (close-logs)\r
-- log-root directory [ drop rotate-log ] assoc-each ;\r
--\r
--: log-server-loop ( -- )\r
- [\r
- receive unclip {\r
- { "log-message" [ (log-message) ] }\r
- { "rotate-logs" [ drop (rotate-logs) ] }\r
- { "close-logs" [ drop (close-logs) ] }\r
- } case\r
- ] [ error. (close-logs) ] recover\r
- log-server-loop ;\r
- receive unclip {\r
- { "log-message" [ (log-message) ] }\r
- { "rotate-logs" [ drop (rotate-logs) ] }\r
- { "close-logs" [ drop (close-logs) ] }\r
- } case log-server-loop ;\r
--\r
--: log-server ( -- )\r
- [ log-server-loop ] spawn "log-server" set-global ;\r
- [ [ log-server-loop ] [ error. (close-logs) ] recover t ]\r
- "Log server" spawn-server\r
- "log-server" set-global ;\r
--\r
--[\r
-- H{ } clone log-files set-global\r
-- log-server\r
--] "logging" add-init-hook\r
++! Copyright (C) 2008 Slava Pestov.
++! See http://factorcode.org/license.txt for BSD license.
++USING: namespaces kernel io calendar sequences io.files
++io.sockets continuations prettyprint assocs math.parser
++words debugger math combinators concurrency.messaging
++threads arrays init math.ranges strings io.encodings.utf8 ;
++IN: logging.server
++
++: log-root ( -- string )
++ \ log-root get "logs" resource-path or ;
++
++: log-path ( service -- path )
++ log-root swap path+ ;
++
++: log# ( path n -- path' )
++ number>string ".log" append path+ ;
++
++SYMBOL: log-files
++
++: open-log-stream ( service -- stream )
++ log-path
++ dup make-directories
++ 1 log# utf8 <file-appender> ;
++
++: log-stream ( service -- stream )
++ log-files get [ open-log-stream ] cache ;
++
++: multiline-header 20 CHAR: - <string> ; foldable
++
++: (write-message) ( msg word-name level multi? -- )
++ [
++ "[" write multiline-header write "] " write
++ ] [
++ "[" write now (timestamp>rfc3339) "] " write
++ ] if
++ write bl write ": " write print ;
++
++: write-message ( msg word-name level -- )
++ rot [ empty? not ] subset {
++ { [ dup empty? ] [ 3drop ] }
++ { [ dup length 1 = ] [ first -rot f (write-message) ] }
++ { [ t ] [
++ [ first -rot f (write-message) ] 3keep
++ 1 tail -rot [ t (write-message) ] 2curry each
++ ] }
++ } cond ;
++
++: (log-message) ( msg -- )
++ #! msg: { msg word-name level service }
++ first4 log-stream [ write-message flush ] with-stream* ;
++
++: try-dispose ( stream -- )
++ [ dispose ] curry [ error. ] recover ;
++
++: close-log ( service -- )
++ log-files get delete-at*
++ [ try-dispose ] [ drop ] if ;
++
++: (close-logs) ( -- )
++ log-files get
++ dup values [ try-dispose ] each
++ clear-assoc ;
++
++: keep-logs 10 ;
++
++: ?delete-file ( path -- )
++ dup exists? [ delete-file ] [ drop ] if ;
++
++: delete-oldest keep-logs log# ?delete-file ;
++
++: ?rename-file ( old new -- )
++ over exists? [ rename-file ] [ 2drop ] if ;
++
++: advance-log ( path n -- )
++ [ 1- log# ] 2keep log# ?rename-file ;
++
++: rotate-log ( service -- )
++ dup close-log
++ log-path
++ dup delete-oldest
++ keep-logs 1 [a,b] [ advance-log ] with each ;
++
++: (rotate-logs) ( -- )
++ (close-logs)
++ log-root directory [ drop rotate-log ] assoc-each ;
++
++: log-server-loop ( -- )
++ receive unclip {
++ { "log-message" [ (log-message) ] }
++ { "rotate-logs" [ drop (rotate-logs) ] }
++ { "close-logs" [ drop (close-logs) ] }
++ } case log-server-loop ;
++
++: log-server ( -- )
++ [ [ log-server-loop ] [ error. (close-logs) ] recover t ]
++ "Log server" spawn-server
++ "log-server" set-global ;
++
++[
++ H{ } clone log-files set-global
++ log-server
++] "logging" add-init-hook
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: io io.files io.streams.lines io.streams.plain io.streams.duplex
- listener ;
+ listener io.encodings.utf8 ;
: tty-listener ( tty -- )
- [ utf8 <file-reader> ] [ utf8 <file-writer> ] bi <duplex-stream>
- [ listener ] with-stream ;
- dup <file-reader> [
- swap <file-writer> [
++ dup utf8 <file-reader> [
++ swap utf8 <file-writer> [
+ <duplex-stream> [
+ listener
+ ] with-stream
+ ] with-disposal
+ ] with-disposal ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: combinators io io.files io.streams.duplex
io.streams.string kernel math math.parser continuations
namespaces pack prettyprint sequences strings system
- hexdump tools.interpreter io.encodings.binary ;
-hexdump ;
++hexdump io.encodings.binary ;
IN: tar
: zero-checksum 256 ;
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io words alien kernel math.parser alien.syntax
io.launcher system assocs arrays sequences namespaces qualified
- system math windows.kernel32 generator.fixup io.encodings.ascii ;
-system math generator.fixup ;
++system math generator.fixup io.encodings.ascii ;
IN: tools.disassembler
: in-file "gdb-in.txt" resource-path ;
--- /dev/null
-tools.test io io.files continuations alien.c-types splitting generic.math ;
+ USING: cryptlib.libcl cryptlib prettyprint kernel alien sequences libc math
- file-contents set-pop-buffer
++tools.test io io.files continuations alien.c-types splitting generic.math
++io.encodings.binary ;
+
+ "=========================================================" print
+ "Envelope/de-envelop test..." print
+ "=========================================================" print
+
+ [
+ ! envelope
+ CRYPT_FORMAT_CRYPTLIB [
+ "Hello world" set-pop-buffer
+ envelope-handle CRYPT_ENVINFO_DATASIZE
+ get-pop-buffer alien>char-string length set-attribute
+ envelope-handle get-pop-buffer dup alien>char-string length push-data
+ get-bytes-copied .
+ envelope-handle flush-data
+ envelope-handle 1024 pop-data
+ get-bytes-copied .
+ pop-buffer-string .
+ ] with-envelope
+
+ ! de-envelope
+ CRYPT_FORMAT_AUTO [
+ envelope-handle get-pop-buffer get-bytes-copied push-data
+ get-bytes-copied .
+ envelope-handle flush-data
+ envelope-handle get-bytes-copied pop-data
+ get-bytes-copied .
+ [ "Hello world" ] [ pop-buffer-string ] unit-test
+ ] with-envelope
+
+ ] with-cryptlib
+
+ "=========================================================" print
+ "Password encryption test..." print
+ "=========================================================" print
+
+ [
+ ! envelope
+ CRYPT_FORMAT_CRYPTLIB [
+ envelope-handle CRYPT_ENVINFO_PASSWORD "password" set-attribute-string
+ "Hello world" set-pop-buffer
+ envelope-handle CRYPT_ENVINFO_DATASIZE
+ get-pop-buffer alien>char-string length set-attribute
+ envelope-handle get-pop-buffer dup alien>char-string length push-data
+ get-bytes-copied .
+ envelope-handle flush-data
+ envelope-handle 1024 pop-data
+ get-bytes-copied .
+ pop-buffer-string .
+ ] with-envelope
+
+ ! de-envelope
+ CRYPT_FORMAT_AUTO [
+ [ envelope-handle get-pop-buffer get-bytes-copied push-data ] [
+ dup CRYPT_ENVELOPE_RESOURCE = [
+ envelope-handle CRYPT_ENVINFO_PASSWORD
+ "password" set-attribute-string
+ ] [
+ rethrow
+ ] if
+ ] recover drop
+ get-bytes-copied .
+ envelope-handle flush-data
+ envelope-handle get-bytes-copied pop-data
+ get-bytes-copied .
+ [ "Hello world" ] [ pop-buffer-string ] unit-test
+ ] with-envelope
+ ] with-cryptlib
+
+ "=========================================================" print
+ "Compression test..." print
+ "=========================================================" print
+
+ [
+ ! envelope
+ CRYPT_FORMAT_CRYPTLIB [
+ envelope-handle CRYPT_ENVINFO_COMPRESSION CRYPT_UNUSED set-attribute
+ "Hello world" set-pop-buffer
+ envelope-handle CRYPT_ENVINFO_DATASIZE
+ get-pop-buffer alien>char-string length set-attribute
+ envelope-handle get-pop-buffer dup alien>char-string length push-data
+ get-bytes-copied .
+ envelope-handle flush-data
+ envelope-handle 1024 pop-data
+ get-bytes-copied .
+ pop-buffer-string .
+ ] with-envelope
+
+ ! de-envelope
+ CRYPT_FORMAT_AUTO [
+ envelope-handle get-pop-buffer get-bytes-copied push-data
+ get-bytes-copied .
+ envelope-handle flush-data
+ envelope-handle get-bytes-copied pop-data
+ get-bytes-copied .
+ [ "Hello world" ] [ pop-buffer-string ] unit-test
+ ] with-envelope
+ ] with-cryptlib
+
+ "=========================================================" print
+ "Conventional encryption test..." print
+ "=========================================================" print
+
+ [
+ ! envelope
+ CRYPT_FORMAT_CRYPTLIB [
+ CRYPT_ALGO_IDEA [
+ context-handle CRYPT_CTXINFO_KEY "0123456789ABCDEF" set-attribute-string
+ envelope-handle CRYPT_ENVINFO_SESSIONKEY context-handle *int set-attribute
+ ] with-context
+
+ "Hello world" set-pop-buffer
+ envelope-handle CRYPT_ENVINFO_DATASIZE
+ get-pop-buffer alien>char-string length set-attribute
+ envelope-handle get-pop-buffer dup alien>char-string length push-data
+ get-bytes-copied .
+ envelope-handle flush-data
+ envelope-handle 1024 pop-data
+ get-bytes-copied .
+ pop-buffer-string .
+ ] with-envelope
+
+ ! de-envelope
+ CRYPT_FORMAT_AUTO [
+ [ envelope-handle get-pop-buffer get-bytes-copied push-data ] [
+ dup CRYPT_ENVELOPE_RESOURCE = [
+ CRYPT_ALGO_IDEA create-context
+ context-handle CRYPT_CTXINFO_KEY "0123456789ABCDEF"
+ set-attribute-string
+ envelope-handle CRYPT_ENVINFO_SESSIONKEY context-handle *int
+ set-attribute
+ ] [
+ rethrow
+ ] if
+ ] recover drop
+
+ get-bytes-copied .
+ destroy-context
+ envelope-handle flush-data
+ envelope-handle get-bytes-copied pop-data
+ get-bytes-copied .
+ [ "Hello world" ] [ pop-buffer-string ] unit-test
+ ] with-envelope
+ ] with-cryptlib
+
+ "=========================================================" print
+ "Large data size envelope/de-envelop test..." print
+ "=========================================================" print
+
+ [
+ ! envelope
+ CRYPT_FORMAT_CRYPTLIB [
+ "extra/cryptlib/test/large_data.txt" resource-path
- file-contents set-pop-buffer
++ binary file-contents set-pop-buffer
+ envelope-handle CRYPT_ATTRIBUTE_BUFFERSIZE
+ get-pop-buffer alien>char-string length 10000 + set-attribute
+ envelope-handle CRYPT_ENVINFO_DATASIZE
+ get-pop-buffer alien>char-string length set-attribute
+ envelope-handle get-pop-buffer dup alien>char-string length push-data
+ get-bytes-copied .
+ envelope-handle flush-data
+ envelope-handle get-pop-buffer alien>char-string length 10000 + pop-data
+ get-bytes-copied .
+ ! pop-buffer-string .
+ ] with-envelope
+
+ ! de-envelope
+ CRYPT_FORMAT_AUTO [
+ envelope-handle CRYPT_ATTRIBUTE_BUFFERSIZE
+ get-pop-buffer alien>char-string length 10000 + set-attribute
+ envelope-handle get-pop-buffer get-bytes-copied push-data
+ get-bytes-copied .
+ envelope-handle flush-data
+ envelope-handle get-bytes-copied pop-data
+ get-bytes-copied .
+ ! pop-buffer-string .
+ [ "/opt/local/lib/libcl.dylib(dylib1.o):" ]
+ [ pop-buffer-string "\n" split first ] unit-test
+ [ "00000000 t __mh_dylib_header" ]
+ [ pop-buffer-string "\n" split last/first first ] unit-test
+ ] with-envelope
+ ] with-cryptlib
+
+ "=========================================================" print
+ "Large data size password encryption test..." print
+ "=========================================================" print
+
+ [
+
+ ! envelope
+ CRYPT_FORMAT_CRYPTLIB [
+ envelope-handle CRYPT_ENVINFO_PASSWORD "password" set-attribute-string
+ "extra/cryptlib/test/large_data.txt" resource-path
++ binary file-contents set-pop-buffer
+ envelope-handle CRYPT_ATTRIBUTE_BUFFERSIZE
+ get-pop-buffer alien>char-string length 10000 + set-attribute
+ envelope-handle CRYPT_ENVINFO_DATASIZE
+ get-pop-buffer alien>char-string length set-attribute
+ envelope-handle get-pop-buffer dup alien>char-string length push-data
+ get-bytes-copied .
+ envelope-handle flush-data
+ envelope-handle get-pop-buffer alien>char-string length 10000 + pop-data
+ get-bytes-copied .
+ pop-buffer-string .
+ ] with-envelope
+
+ ! de-envelope
+ CRYPT_FORMAT_AUTO [
+ envelope-handle CRYPT_ATTRIBUTE_BUFFERSIZE 130000 set-attribute
+ [ envelope-handle get-pop-buffer get-bytes-copied push-data ] [
+ dup CRYPT_ENVELOPE_RESOURCE = [
+ envelope-handle CRYPT_ENVINFO_PASSWORD
+ "password" set-attribute-string
+ ] [
+ rethrow
+ ] if
+ ] recover drop
+
+ get-bytes-copied .
+ envelope-handle flush-data
+ envelope-handle get-bytes-copied pop-data
+ get-bytes-copied .
+ ! pop-buffer-string .
+
+ [ "/opt/local/lib/libcl.dylib(dylib1.o):" ]
+ [ pop-buffer-string "\n" split first ] unit-test
+
+ [ "00000000 t __mh_dylib_header" ]
+ [ pop-buffer-string "\n" split last/first first ] unit-test
+ ] with-envelope
+ ] with-cryptlib
+
+ "=========================================================" print
+ "Generating a key pair test..." print
+ "=========================================================" print
+
+ [
+ CRYPT_ALGO_RSA [
+ context-handle CRYPT_CTXINFO_LABEL "private key" set-attribute-string
+
+ ! a particular key length can be set (e.g. 1536-bit/192-byte key)
+ context-handle CRYPT_CTXINFO_KEYSIZE 1536 8 / set-attribute
+
+ context-handle generate-key
+
+ CRYPT_KEYSET_FILE "extra/cryptlib/test/keys.p15" resource-path
+ CRYPT_KEYOPT_CREATE [
+ "password" add-private-key
+ ] with-keyset
+ ] with-context
+ ] with-cryptlib
+
+ "Passed" print
+
+ "=========================================================" print
+ "Simple certificate creation test..." print
+ "=========================================================" print
+
+ [
+ CRYPT_ALGO_RSA [
+ context-handle CRYPT_CTXINFO_LABEL "private key" set-attribute-string
+ context-handle generate-key
+ CRYPT_KEYSET_FILE "extra/cryptlib/test/keys.p15" resource-path
+ CRYPT_KEYOPT_CREATE [
+ "password" add-private-key
+ CRYPT_CERTTYPE_CERTIFICATE [
+ certificate-handle CRYPT_CERTINFO_XYZZY 1 set-attribute
+ certificate-handle CRYPT_CERTINFO_SUBJECTPUBLICKEYINFO
+ context-handle *int set-attribute
+ certificate-handle CRYPT_CERTINFO_COMMONNAME "Dave Smith"
+ set-attribute-string
+ sign-certificate
+ check-certificate
+ add-public-key
+ f 0 CRYPT_CERTFORMAT_TEXT_CERTIFICATE export-certificate
+ get-cert-length *int dup malloc swap
+ CRYPT_CERTFORMAT_TEXT_CERTIFICATE export-certificate
+ get-cert-buffer alien>char-string print
+ ] with-certificate
+ ] with-keyset
+ ] with-context
+ ] with-cryptlib
+
+ : ssh-session ( -- )
+ "=========================================================" print
+ "SSH session test..." print
+ "=========================================================" print
+
+ ! start client connection with:
+ ! ssh -v localhost -p3000
+ "waiting for: ssh -v localhost -p3000" print flush
+
+ ! Are you sure you want to continue connecting (yes/no)? yes
+ ! ...
+ ! <at> localhost's password: (any password will be accepted)
+
+ ! If you want to run the test again you should clean the [localhost]:3000
+ ! ssh-rsa entry in the known_hosts file, in your home directory under the .ssh
+ ! folder, since the test generates a new RSA certificate on every run.
+
+ [
+ CRYPT_KEYSET_FILE "extra/cryptlib/test/keys.p15" resource-path
+ CRYPT_KEYOPT_READONLY [
+ CRYPT_KEYID_NAME "private key" "password" get-private-key
+
+ CRYPT_SESSION_SSH_SERVER [
+
+ session-handle CRYPT_SESSINFO_SERVER_NAME "localhost"
+ set-attribute-string
+
+ session-handle CRYPT_SESSINFO_SERVER_PORT 3000 set-attribute
+
+ session-handle CRYPT_SESSINFO_PRIVATEKEY
+
+ context-handle *int set-attribute
+
+ [ session-handle CRYPT_SESSINFO_ACTIVE 1 set-attribute ] [
+ dup CRYPT_ENVELOPE_RESOURCE = [
+ session-handle CRYPT_SESSINFO_AUTHRESPONSE 1
+ set-attribute
+
+ session-handle CRYPT_SESSINFO_ACTIVE 1 set-attribute
+
+ "Welcome to cryptlib, now go away.\r\n" set-pop-buffer
+
+ session-handle get-pop-buffer dup alien>char-string
+ length push-data
+
+ session-handle flush-data
+ ] [
+ rethrow
+ ] if
+ ] recover drop
+ ] with-session
+ ] with-keyset
+ ] with-cryptlib
+
+ "Passed" print
+ ;
+
+ : ssl-session ( -- )
+ "=========================================================" print
+ "SSL session test..." print
+ "=========================================================" print
+
+ ! start client connection with:
+ ! curl -k https://localhost:3000
+ "waiting for: curl -k https://localhost:3000" print flush
+
+ [
+ CRYPT_KEYSET_FILE "extra/cryptlib/test/keys.p15" resource-path
+ CRYPT_KEYOPT_READONLY [
+ CRYPT_KEYID_NAME "private key" "password" get-private-key
+
+ CRYPT_SESSION_SSL_SERVER [
+ session-handle CRYPT_SESSINFO_SERVER_NAME "localhost"
+ set-attribute-string
+ session-handle CRYPT_SESSINFO_SERVER_PORT 3000 set-attribute
+ session-handle CRYPT_OPTION_NET_WRITETIMEOUT 10 set-attribute
+ session-handle CRYPT_OPTION_NET_READTIMEOUT 10 set-attribute
+ session-handle CRYPT_OPTION_NET_CONNECTTIMEOUT 10 set-attribute
+ session-handle CRYPT_SESSINFO_PRIVATEKEY
+ context-handle *int set-attribute
+
+ session-handle CRYPT_SESSINFO_ACTIVE 1 set-attribute
+ "Welcome to cryptlib, now go away.\r\n" set-pop-buffer
+ session-handle get-pop-buffer dup alien>char-string
+ length push-data
+ session-handle flush-data
+ ] with-session
+ ] with-keyset
+ ] with-cryptlib
+
+ "Passed" print
+ ;
--- /dev/null
-splitting strings assocs unicode.categories ;
+ ! Copyright (C) 2007 Adam Wendt.
+ ! See http://factorcode.org/license.txt for BSD license.
+
+ USING: arrays combinators io io.binary io.files io.paths
+ io.encodings.utf16 kernel math math.parser namespaces sequences
- [ 3 4 ] member? ;
++splitting strings assocs unicode.categories io.encodings.binary ;
+
+ IN: id3
+
+ TUPLE: tag header frames ;
+ C: <tag> tag
+
+ TUPLE: header version revision flags size extended-header ;
+ C: <header> header
+
+ TUPLE: frame id size flags data ;
+ C: <frame> frame
+
+ TUPLE: extended-header size flags update crc restrictions ;
+ C: <extended-header> extended-header
+
+ : debug-stream ( msg -- )
+ ! global [ . flush ] bind ;
+ drop ;
+
+ : >hexstring ( str -- hex )
+ >array [ >hex 2 CHAR: 0 pad-left ] map concat ;
+
+ : good-frame-id? ( id -- ? )
+ [ [ LETTER? ] keep digit? or ] all? ;
+
+ ! 4 byte syncsafe integer (28 effective bits)
+ : >syncsafe ( seq -- int )
+ 0 [ >r 7 shift r> bitor ] reduce ;
+
+ : read-size ( -- size )
+ 4 read >syncsafe ;
+
+ : read-frame-id ( -- id )
+ 4 read ;
+
+ : read-frame-flags ( -- flags )
+ 2 read ;
+
+ : read-frame-size ( -- size )
+ 4 read be> ;
+
+ : text-frame? ( id -- ? )
+ "T" head? ;
+
+ : read-text ( size -- text )
+ read1 swap 1 - read swap 1 = [ decode-utf16 ] [ ] if
+ "\0" ?tail drop ; ! remove null terminator
+
+ : read-popm ( size -- popm )
+ read-text ;
+
+ : read-frame-data ( id size -- data )
+ swap
+ {
+ { [ dup text-frame? ] [ drop read-text ] }
+ { [ "POPM" = ] [ read-popm ] }
+ { [ t ] [ read ] }
+ } cond ;
+
+ : (read-frame) ( id -- frame )
+ read-frame-size read-frame-flags 2over read-frame-data <frame> ;
+
+ : read-frame ( -- frame/f )
+ read-frame-id dup good-frame-id? [ (read-frame) ] [ drop f ] if ;
+
+ : (read-frames) ( vector -- frames )
+ read-frame [ over push (read-frames) ] when* ;
+
+ : read-frames ( -- frames )
+ V{ } clone (read-frames) ;
+
+ : read-eh-flags ( -- flags )
+ read1 read le> ;
+
+ : read-eh-data ( size -- data )
+ 6 - read ;
+
+ : read-crc ( flags -- crc )
+ 5 bit? [ read1 read >syncsafe ] [ f ] if ;
+
+ : tag-is-update? ( flags -- ? )
+ 6 bit? dup [ read1 drop ] [ ] if ;
+
+ : (read-tag-restrictions) ( -- restrictions )
+ read1 dup read le> ;
+
+ : read-tag-restrictions ( flags -- restrictions/f )
+ 4 bit? [ (read-tag-restrictions) ] [ f ] if ;
+
+ : (read-extended-header) ( -- extended-header )
+ read-size read-eh-flags dup tag-is-update? over dup
+ read-crc swap read-tag-restrictions <extended-header> ;
+
+ : read-extended-header ( flags -- extended-header/f )
+ 6 bit? [ (read-extended-header) ] [ f ] if ;
+
+ : read-header ( version -- header )
+ read1 read1 read-size over read-extended-header <header> ;
+
+ : (read-id3v2) ( version -- tag )
+ read-header read-frames <tag> ;
+
+ : supported-version? ( version -- ? )
- 3 read "ID3" = ;
++ { 3 4 } member? ;
+
+ : read-id3v2 ( -- tag/f )
+ read1 dup supported-version?
+ [ (read-id3v2) ] [ drop f ] if ;
+
+ : id3v2? ( -- ? )
- [ read-tag ] with-file-reader ;
++ 3 read "ID3" sequence= ;
+
+ : read-tag ( stream -- tag/f )
+ id3v2? [ read-id3v2 ] [ f ] if ;
+
+ : id3v2 ( filename -- tag/f )
- [ id3v2? ] with-file-reader ;
++ binary [ read-tag ] with-file-reader ;
+
+ : file? ( path -- ? )
+ stat 3drop not ;
+
+ : files ( paths -- files )
+ [ file? ] subset ;
+
+ : mp3? ( path -- ? )
+ ".mp3" tail? ;
+
+ : mp3s ( paths -- mp3s )
+ [ mp3? ] subset ;
+
+ : id3? ( file -- ? )
++ binary [ id3v2? ] with-file-reader ;
+
+ : id3s ( files -- id3s )
+ [ id3? ] subset ;
+
--- /dev/null
- namespaces prettyprint sbufs sequences tools.interpreter vars ;\r
+ ! Copyright (C) 2007 Adam Wendt.\r
+ ! See http://factorcode.org/license.txt for BSD license.\r
+ USING: alien alien.c-types byte-arrays io io.binary io.files kernel mad\r
-: malloc-file-contents ( path -- alien )\r
- file-contents >byte-array malloc-byte-array ;\r
-\r
++ namespaces prettyprint sbufs sequences tools.interpreter vars\r
++ io.encodings.binary ;\r
+ IN: mad.api\r
+ \r
+ VARS: buffer-start buffer-length output-callback-var ;\r
+ \r
+ : create-mad-callback-generic ( sequence parameters -- alien )\r
+ swap >r >r "mad_flow" r> "cdecl" r> alien-callback ; inline\r
+ \r
+ : create-input-callback ( sequence -- alien )\r
+ { "void*" "mad_stream*" } create-mad-callback-generic ; inline\r
+ \r
+ : create-header-callback ( sequence -- alien )\r
+ { "void*" "mad_header*" } create-mad-callback-generic ; inline\r
+ \r
+ : create-filter-callback ( sequence -- alien )\r
+ { "void*" "mad_stream*" "mad_frame*" } create-mad-callback-generic ; inline\r
+ \r
+ : create-output-callback ( sequence -- alien )\r
+ { "void*" "mad_header*" "mad_pcm*" } create-mad-callback-generic ; inline\r
+ \r
+ : create-error-callback ( sequence -- alien )\r
+ { "void*" "mad_stream*" "mad_frame*" } create-mad-callback-generic ; inline\r
+ \r
+ : create-message-callback ( sequence -- alien )\r
+ { "void*" "void*" "uint*" } create-mad-callback-generic ; inline\r
+ \r
+ : input ( buffer mad_stream -- mad_flow )\r
+ "input" print flush\r
+ nip ! mad_stream\r
+ buffer-start get ! mad_stream start\r
+ buffer-length get ! mad_stream start length\r
+ dup 0 = ! mad-stream start length bool\r
+ [ 3drop MAD_FLOW_STOP ] ! mad_flow\r
+ [ mad_stream_buffer ! \r
+ 0 buffer-length set ! \r
+ MAD_FLOW_CONTINUE ] if ; ! mad_flow\r
+ \r
+ : input-callback ( -- callback )\r
+ [ input ] create-input-callback ;\r
+ \r
+ : header-callback ( -- callback )\r
+ [ "header" print flush drop drop MAD_FLOW_CONTINUE ] create-header-callback ;\r
+ \r
+ : filter-callback ( -- callback )\r
+ [ "filter" print flush 3drop MAD_FLOW_CONTINUE ] create-filter-callback ;\r
+ \r
+ : write-sample ( sample -- )\r
+ 4 >le write ;\r
+ \r
+ : output ( data header pcm -- mad_flow )\r
+ "output" . flush\r
+ -rot 2drop output-callback-var> call\r
+ [ MAD_FLOW_CONTINUE ] [ MAD_FLOW_STOP ] if ;\r
+ \r
+ : output-stdout ( pcm -- ? )\r
+ [ mad_pcm-channels ] keep\r
+ [ mad_pcm-length ] keep swap\r
+ [\r
+ [ mad_pcm-sample-right ] 2keep\r
+ [ mad_pcm-sample-left ] 2keep\r
+ drop -rot write-sample pick\r
+ 2 = [ write-sample ] [ drop ] if\r
+ ] each drop t ;\r
+ \r
+ : output-callback ( -- callback )\r
+ [ output ] create-output-callback ;\r
+ \r
+ : error-callback ( -- callback )\r
+ [ "error" print flush drop drop drop MAD_FLOW_CONTINUE ] create-error-callback ;\r
+ \r
+ : message-callback ( -- callback )\r
+ [ "message" print flush drop drop drop MAD_FLOW_CONTINUE ] create-message-callback ;\r
+ \r
+ : mad-init ( decoder -- )\r
+ 0 <alien> input-callback 0 <alien> 0 <alien> output-callback error-callback message-callback mad_decoder_init ;\r
+ \r
+ : make-decoder ( -- decoder )\r
+ "mad_decoder" malloc-object ;\r
+ \r
+ : mad-run ( -- int )\r
+ make-decoder [ mad-init ] keep MAD_DECODER_MODE_SYNC mad_decoder_run ;\r
+ \r
+ : init-vars ( alien length -- )\r
+ buffer-length set buffer-start set ;\r
+ \r
+ : decode-mp3 ( filename -- results )\r
+ [ malloc-file-contents ] keep file-length init-vars mad-run ;\r
+ \r
+ : mad-test ( -- results )\r
+ [ output-stdout ] >output-callback-var\r
+ "/home/adam/download/mp3/Misc/wutbf.mp3" decode-mp3 ;\r
projects / factor.git / commitdiff