Merge branch 'master' of http://factorcode.org/git/factor
Alex Chapman
commit
547dd65c23
|
|
@ -1 +1,2 @@
|
|||
unportable
|
||||
bindings
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
unportable
|
||||
bindings
|
||||
|
|
@ -139,7 +139,6 @@ check_library_exists() {
|
|||
}
|
||||
|
||||
check_X11_libraries() {
|
||||
check_library_exists GLU
|
||||
check_library_exists GL
|
||||
check_library_exists X11
|
||||
check_library_exists pango-1.0
|
||||
|
|
@ -491,7 +490,7 @@ make_boot_image() {
|
|||
}
|
||||
|
||||
install_build_system_apt() {
|
||||
sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
|
||||
sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev wget git-core git-doc rlwrap gcc make
|
||||
check_ret sudo
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -45,11 +45,11 @@ M: sequence chat-put [ chat-put ] with each ;
|
|||
|
||||
! Server message handling
|
||||
|
||||
GENERIC: forward-message ( irc-message -- )
|
||||
M: irc-message forward-message +server-chat+ chat-put ;
|
||||
M: to-one-chat forward-message dup chat> chat-put ;
|
||||
M: to-all-chats forward-message chats> chat-put ;
|
||||
M: to-many-chats forward-message dup sender>> participant-chats chat-put ;
|
||||
GENERIC: message-forwards ( irc-message -- seq )
|
||||
M: irc-message message-forwards drop +server-chat+ ;
|
||||
M: to-one-chat message-forwards chat> ;
|
||||
M: to-all-chats message-forwards drop chats> ;
|
||||
M: to-many-chats message-forwards sender>> participant-chats ;
|
||||
|
||||
GENERIC: process-message ( irc-message -- )
|
||||
M: object process-message drop ;
|
||||
|
|
@ -91,7 +91,7 @@ M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
|
|||
: handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ;
|
||||
|
||||
: (handle-disconnect) ( -- )
|
||||
irc> in-messages>> irc-disconnected swap mailbox-put
|
||||
irc-disconnected irc> in-messages>> mailbox-put
|
||||
irc> reconnect-time>> sleep
|
||||
(connect-irc)
|
||||
(do-login) ;
|
||||
|
|
@ -113,8 +113,12 @@ M: f handle-input handle-disconnect ;
|
|||
! Processing loops
|
||||
|
||||
: in-multiplexer-loop ( -- ? )
|
||||
irc> in-messages>> mailbox-get
|
||||
[ process-message ] [ forward-message ] [ irc-end? not ] tri ;
|
||||
irc> in-messages>> mailbox-get {
|
||||
[ message-forwards ]
|
||||
[ process-message ]
|
||||
[ swap chat-put ]
|
||||
[ irc-end? not ]
|
||||
} cleave ;
|
||||
|
||||
: strings>privmsg ( name string -- privmsg )
|
||||
" :" prepend append "PRIVMSG " prepend string>irc-message ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Bruno Deferrari
|
||||
|
|
@ -0,0 +1 @@
|
|||
Bruno Deferrari
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors irc.messages irc.messages.base kernel make ;
|
||||
EXCLUDE: sequences => join ;
|
||||
IN: irc.logbot.log-line
|
||||
|
||||
: dot-or-parens ( string -- string )
|
||||
[ "." ] [ " (" prepend ")." append ] if-empty ;
|
||||
|
||||
GENERIC: >log-line ( object -- line )
|
||||
|
||||
M: irc-message >log-line line>> ;
|
||||
|
||||
M: privmsg >log-line
|
||||
[ "<" % dup sender>> % "> " % text>> % ] "" make ;
|
||||
|
||||
M: join >log-line
|
||||
[ "* " % sender>> % " has joined the channel." % ] "" make ;
|
||||
|
||||
M: part >log-line
|
||||
[ "* " % dup sender>> % " has left the channel" %
|
||||
comment>> dot-or-parens % ] "" make ;
|
||||
|
||||
M: quit >log-line
|
||||
[ "* " % dup sender>> % " has quit" %
|
||||
comment>> dot-or-parens % ] "" make ;
|
||||
|
||||
M: kick >log-line
|
||||
[ "* " % dup sender>> % " has kicked " % dup user>> %
|
||||
" from the channel" % comment>> dot-or-parens % ] "" make ;
|
||||
|
||||
M: participant-mode >log-line
|
||||
[ "* " % dup sender>> % " has set mode " % dup mode>> %
|
||||
" to " % parameter>> % ] "" make ;
|
||||
|
||||
M: nick >log-line
|
||||
[ "* " % dup sender>> % " is now known as " % nickname>> % ] "" make ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
IRC message formatting for logs
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors calendar calendar.format destructors fry io io.encodings.8-bit
|
||||
io.files io.pathnames irc.client irc.client.chats irc.messages
|
||||
irc.messages.base kernel make namespaces sequences threads
|
||||
irc.logbot.log-line ;
|
||||
IN: irc.logbot
|
||||
|
||||
CONSTANT: bot-channel "#concatenative"
|
||||
CONSTANT: log-directory "/tmp/logs"
|
||||
|
||||
SYMBOL: current-day
|
||||
SYMBOL: current-stream
|
||||
|
||||
: bot-profile ( -- obj )
|
||||
"irc.freenode.org" 6667 "flogger" f <irc-profile> ;
|
||||
|
||||
: add-timestamp ( string timestamp -- string )
|
||||
timestamp>hms "[" prepend "] " append prepend ;
|
||||
|
||||
: timestamp-path ( timestamp -- path )
|
||||
timestamp>ymd ".log" append log-directory prepend-path ;
|
||||
|
||||
: timestamp>stream ( timestamp -- stream )
|
||||
dup day-of-year current-day get = [
|
||||
drop
|
||||
] [
|
||||
current-stream get [ dispose ] when*
|
||||
[ day-of-year current-day set ]
|
||||
[ timestamp-path latin1 <file-writer> ] bi
|
||||
current-stream set
|
||||
] if current-stream get ;
|
||||
|
||||
: log-message ( string timestamp -- )
|
||||
[ add-timestamp ] [ timestamp>stream ] bi
|
||||
[ stream-print ] [ stream-flush ] bi ;
|
||||
|
||||
GENERIC: handle-message ( msg -- )
|
||||
|
||||
M: object handle-message drop ;
|
||||
M: irc-message handle-message [ >log-line ] [ timestamp>> ] bi log-message ;
|
||||
|
||||
: bot-loop ( chat -- ) dup hear handle-message bot-loop ;
|
||||
|
||||
: start-bot ( -- )
|
||||
bot-profile <irc-client>
|
||||
[ connect-irc ]
|
||||
[
|
||||
[ bot-channel <irc-channel-chat> ] dip
|
||||
'[ _ [ _ attach-chat ] [ bot-loop ] bi ]
|
||||
"LogBot" spawn drop
|
||||
] bi ;
|
||||
|
||||
: logbot ( -- ) start-bot ;
|
||||
|
||||
MAIN: logbot
|
||||
|
|
@ -0,0 +1 @@
|
|||
An IRC logging bot
|
||||
|
|
@ -58,7 +58,8 @@ IN: irc.messages.tests
|
|||
{ command "NICK" }
|
||||
{ parameters { } }
|
||||
{ trailing "someuser2" }
|
||||
{ sender "someuser" } } }
|
||||
{ sender "someuser" }
|
||||
{ nickname "someuser2" } } }
|
||||
[ ":someuser!n=user@some.where NICK :someuser2"
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: irc.messages
|
|||
|
||||
! connection
|
||||
IRC: pass "PASS" password ;
|
||||
IRC: nick "NICK" nickname ;
|
||||
IRC: nick "NICK" : nickname ;
|
||||
IRC: user "USER" user mode _ : realname ;
|
||||
IRC: oper "OPER" name password ;
|
||||
IRC: mode "MODE" name mode parameter ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,10 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators io io.files io.files.links io.directories
|
||||
io.pathnames io.streams.string kernel math math.parser
|
||||
continuations namespaces pack prettyprint sequences strings
|
||||
system tools.hexdump io.encodings.binary summary accessors
|
||||
io.backend byte-arrays ;
|
||||
io.backend byte-arrays io.streams.byte-array splitting ;
|
||||
IN: tar
|
||||
|
||||
CONSTANT: zero-checksum 256
|
||||
|
|
@ -10,37 +12,35 @@ CONSTANT: block-size 512
|
|||
|
||||
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
|
||||
linkname magic version uname gname devmajor devminor prefix ;
|
||||
|
||||
ERROR: checksum-error ;
|
||||
|
||||
SYMBOLS: base-dir filename ;
|
||||
: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
|
||||
|
||||
: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
|
||||
|
||||
: read-c-string* ( n -- str/f )
|
||||
: read-c-string ( n -- str/f )
|
||||
read [ zero? ] trim-tail [ f ] when-empty ;
|
||||
|
||||
: read-tar-header ( -- obj )
|
||||
\ tar-header new
|
||||
100 read-c-string* >>name
|
||||
8 read-c-string* tar-trim oct> >>mode
|
||||
8 read-c-string* tar-trim oct> >>uid
|
||||
8 read-c-string* tar-trim oct> >>gid
|
||||
12 read-c-string* tar-trim oct> >>size
|
||||
12 read-c-string* tar-trim oct> >>mtime
|
||||
8 read-c-string* tar-trim oct> >>checksum
|
||||
100 read-c-string >>name
|
||||
8 read-c-string trim-string oct> >>mode
|
||||
8 read-c-string trim-string oct> >>uid
|
||||
8 read-c-string trim-string oct> >>gid
|
||||
12 read-c-string trim-string oct> >>size
|
||||
12 read-c-string trim-string oct> >>mtime
|
||||
8 read-c-string trim-string oct> >>checksum
|
||||
read1 >>typeflag
|
||||
100 read-c-string* >>linkname
|
||||
100 read-c-string >>linkname
|
||||
6 read >>magic
|
||||
2 read >>version
|
||||
32 read-c-string* >>uname
|
||||
32 read-c-string* >>gname
|
||||
8 read tar-trim oct> >>devmajor
|
||||
8 read tar-trim oct> >>devminor
|
||||
155 read-c-string* >>prefix ;
|
||||
32 read-c-string >>uname
|
||||
32 read-c-string >>gname
|
||||
8 read trim-string oct> >>devmajor
|
||||
8 read trim-string oct> >>devminor
|
||||
155 read-c-string >>prefix ;
|
||||
|
||||
: header-checksum ( seq -- x )
|
||||
148 cut-slice 8 tail-slice
|
||||
[ sum ] bi@ + 256 + ;
|
||||
: checksum-header ( seq -- n )
|
||||
148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
|
||||
|
||||
: read-data-blocks ( tar-header -- )
|
||||
dup size>> 0 > [
|
||||
|
|
@ -60,29 +60,34 @@ SYMBOLS: base-dir filename ;
|
|||
] if ;
|
||||
|
||||
: parse-tar-header ( seq -- obj )
|
||||
[ header-checksum ] keep over zero-checksum = [
|
||||
[ checksum-header ] keep over zero-checksum = [
|
||||
2drop
|
||||
\ tar-header new
|
||||
0 >>size
|
||||
0 >>checksum
|
||||
] [
|
||||
[ read-tar-header ] with-string-reader
|
||||
binary [ read-tar-header ] with-byte-reader
|
||||
[ checksum>> = [ checksum-error ] unless ] keep
|
||||
] if ;
|
||||
|
||||
ERROR: unknown-typeflag ch ;
|
||||
M: unknown-typeflag summary ( obj -- str )
|
||||
ch>> 1string "Unknown typeflag: " prepend ;
|
||||
|
||||
: tar-prepend-path ( path -- newpath )
|
||||
base-dir get prepend-path ;
|
||||
M: unknown-typeflag summary ( obj -- str )
|
||||
ch>> [ "Unknown typeflag: " ] dip prefix ;
|
||||
|
||||
: read/write-blocks ( tar-header path -- )
|
||||
binary [ read-data-blocks ] with-file-writer ;
|
||||
|
||||
: prepend-current-directory ( path -- path' )
|
||||
current-directory get prepend-path ;
|
||||
|
||||
! Normal file
|
||||
: typeflag-0 ( header -- )
|
||||
dup name>> tar-prepend-path read/write-blocks ;
|
||||
dup name>> dup "global_pax_header" = [
|
||||
drop [ read-data-blocks ] with-string-writer drop
|
||||
] [
|
||||
prepend-current-directory read/write-blocks
|
||||
] if ;
|
||||
|
||||
! Hard link
|
||||
: typeflag-1 ( header -- ) unknown-typeflag ;
|
||||
|
|
@ -99,7 +104,7 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
|
||||
! Directory
|
||||
: typeflag-5 ( header -- )
|
||||
name>> tar-prepend-path make-directories ;
|
||||
name>> prepend-current-directory make-directories ;
|
||||
|
||||
! FIFO
|
||||
: typeflag-6 ( header -- ) unknown-typeflag ;
|
||||
|
|
@ -139,7 +144,7 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
drop ;
|
||||
! <string-writer> [ read-data-blocks ] keep
|
||||
! >string [ zero? ] trim-tail filename set
|
||||
! filename get tar-prepend-path make-directories ;
|
||||
! filename get prepend-current-directory make-directories ;
|
||||
|
||||
! Multi volume continuation entry
|
||||
: typeflag-M ( header -- ) unknown-typeflag ;
|
||||
|
|
@ -157,7 +162,7 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
: typeflag-X ( header -- ) unknown-typeflag ;
|
||||
|
||||
: (parse-tar) ( -- )
|
||||
block-size read dup length 512 = [
|
||||
block-size read dup length block-size = [
|
||||
parse-tar-header
|
||||
dup typeflag>>
|
||||
{
|
||||
|
|
@ -189,7 +194,7 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
drop
|
||||
] if ;
|
||||
|
||||
: parse-tar ( path -- )
|
||||
normalize-path dup parent-directory base-dir [
|
||||
: untar ( path -- )
|
||||
normalize-path [ ] [ parent-directory ] bi [
|
||||
binary [ (parse-tar) ] with-file-reader
|
||||
] with-variable ;
|
||||
] with-directory ;
|
||||
|
|
|
|||
|
|
@ -60,6 +60,7 @@
|
|||
(declaration keyword "declaration words")
|
||||
(ebnf-form constant "EBNF: ... ;EBNF form")
|
||||
(parsing-word keyword "parsing words")
|
||||
(postpone-body comment "postponed form")
|
||||
(setter-word function-name "setter words (>>foo)")
|
||||
(getter-word function-name "getter words (foo>>)")
|
||||
(stack-effect comment "stack effect specifications")
|
||||
|
|
@ -76,20 +77,19 @@
|
|||
(defun fuel-font-lock--syntactic-face (state)
|
||||
(if (nth 3 state) 'factor-font-lock-string
|
||||
(let ((c (char-after (nth 8 state))))
|
||||
(cond ((or (char-equal c ?\ )
|
||||
(char-equal c ?\n)
|
||||
(char-equal c ?E))
|
||||
(cond ((memq c '(?\ ?\n ?E ?P))
|
||||
(save-excursion
|
||||
(goto-char (nth 8 state))
|
||||
(beginning-of-line)
|
||||
(cond ((looking-at-p "USING: ")
|
||||
(cond ((looking-at "E") 'factor-font-lock-ebnf-form)
|
||||
((looking-at "P") 'factor-font-lock-postpone-body)
|
||||
((looking-at-p "USING: ")
|
||||
'factor-font-lock-vocabulary-name)
|
||||
((looking-at-p "\\(TUPLE\\|SYMBOLS\\|VARS\\|SINGLETONS\\):")
|
||||
((looking-at-p
|
||||
"\\(TUPLE\\|SYMBOLS\\|VARS\\|SINGLETONS\\):")
|
||||
'factor-font-lock-symbol)
|
||||
((looking-at-p "C-ENUM:\\( \\|\n\\)")
|
||||
'factor-font-lock-constant)
|
||||
((looking-at-p "E")
|
||||
'factor-font-lock-ebnf-form)
|
||||
(t 'default))))
|
||||
((or (char-equal c ?U) (char-equal c ?C))
|
||||
'factor-font-lock-parsing-word)
|
||||
|
|
@ -102,7 +102,8 @@
|
|||
(,fuel-syntax--alien-function-regex (1 'factor-font-lock-type-name)
|
||||
(2 'factor-font-lock-word))
|
||||
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
|
||||
(,fuel-syntax--constructor-decl-regex (1 'factor-font-lock-word)
|
||||
(,fuel-syntax--constructor-decl-regex
|
||||
(1 'factor-font-lock-word)
|
||||
(2 'factor-font-lock-type-name)
|
||||
(3 'factor-font-lock-invalid-syntax nil t))
|
||||
(,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name)
|
||||
|
|
|
|||
|
|
@ -247,12 +247,14 @@
|
|||
;; Strings and chars
|
||||
("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)"
|
||||
(1 "w") (2 "\"") (4 "\""))
|
||||
("\\(CHAR:\\|POSTPONE:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
|
||||
("\\(CHAR:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
|
||||
("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)"
|
||||
(3 "\"") (5 "\""))
|
||||
("\\_<\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\""))
|
||||
("\\_<<\\(\"\\)\\_>" (1 "<b"))
|
||||
("\\_<\\(\"\\)>\\_>" (1 ">b"))
|
||||
;; postpone
|
||||
("\\_<POSTPONE:\\( \\).*\\(\n\\)" (1 "<b") (2 ">b"))
|
||||
;; Multiline constructs
|
||||
("\\_<\\(E\\)BNF:\\( \\|\n\\)" (1 "<b"))
|
||||
("\\_<;EBN\\(F\\)\\_>" (1 ">b"))
|
||||
|
|
|
|||
Loading…
Reference in New Issue