Renaming of code mostly--words like (blah) should have a corresponding word named blah

cvs
Doug Coleman 2005-10-07 08:31:14 +00:00
parent 79d4d5f20a
commit 9f284c620f
1 changed files with 26 additions and 39 deletions

View File

@ -31,14 +31,10 @@ SYMBOL: message
: client-ssi-flag 1 ; inline : client-ssi-flag 1 ; inline
: client-charset "text/aolrtf; charset=\"us-ascii\"" ; inline : client-charset "text/aolrtf; charset=\"us-ascii\"" ; inline
: initialize ( username password -- ) : initialize-aim ( username password -- )
password set username set
0 65534 random-int seq-num set 0 65534 random-int seq-num set
1 stage-num set 1 stage-num set ;
password set
username set ;
: (send-aim) ( str -- )
conn get [ stream-write ] keep stream-flush ;
: (prepend-aim-protocol) ( data -- ) : (prepend-aim-protocol) ( data -- )
[ [
@ -49,17 +45,11 @@ SYMBOL: message
seq-num [ 1+ ] change seq-num [ 1+ ] change
swap dup >r length (>short) r> append append ; swap dup >r length (>short) r> append append ;
: send-aim-print ( data -- ) : (send-aim) ( str -- )
make-packet conn get [ stream-write ] keep stream-flush ;
(prepend-aim-protocol)
"Sending: " write dup hexdump
(send-aim) ;
: send-aim ( data -- ) : send-aim ( data -- )
make-packet make-packet (prepend-aim-protocol) (send-aim) ;
(prepend-aim-protocol)
"Sending: " write dup hexdump
(send-aim) ;
: with-aim ( quot -- ) : with-aim ( quot -- )
conn get swap with-unscoped-stream ; conn get swap with-unscoped-stream ;
@ -82,7 +72,7 @@ SYMBOL: message
head-short drop head-short drop
head-int drop ; head-int drop ;
: (unhandled-opcode) ( -- ) : (unhandled-opcode) ( str -- )
"Family: " write family get >hex "h" append write "Family: " write family get >hex "h" append write
", opcode: " write opcode get >hex "h" append writeln ", opcode: " write opcode get >hex "h" append writeln
unscoped-stream get contents hexdump ; unscoped-stream get contents hexdump ;
@ -235,32 +225,32 @@ SYMBOL: message
{ [ t ] [ " does 4h.14h unknown: " write unparse writeln ] } { [ t ] [ " does 4h.14h unknown: " write unparse writeln ] }
} cond ; FAMILY: 4 OPCODE: 14 } cond ; FAMILY: 4 OPCODE: 14
: (print-op) ( op -- ) : print-op ( op -- )
"Op: " write . ; "Op: " write . ;
: (parse-server) ( ip:port -- ) : (parse-server) ( ip:port -- )
":" split [ first ] keep second string>number aim-chat-port set aim-chat-ip set ; ":" split [ first ] keep second string>number aim-chat-port set aim-chat-ip set ;
: (process-login-chunks) ( stream -- ) : process-login-chunks ( stream -- )
unscoped-stream get empty? [ unscoped-stream get empty? [
head-short head-short
head-short head-short
swap swap
{ {
! { [ dup 1 = ] [ (print-op) head-string . ] } ! { [ dup 1 = ] [ print-op head-string . ] }
{ [ dup 5 = ] [ drop head-string (parse-server) ] } { [ dup 5 = ] [ drop head-string (parse-server) ] }
{ [ dup 6 = ] [ drop head-string auth-code set ] } { [ dup 6 = ] [ drop head-string auth-code set ] }
! { [ dup 8 = ] [ (print-op) head-string . ] } ! { [ dup 8 = ] [ print-op head-string . ] }
! { [ t ] [ (print-op) head-string . ] } ! { [ t ] [ print-op head-string . ] }
{ [ t ] [ drop head-string drop ] } { [ t ] [ drop head-string drop ] }
} cond } cond
(process-login-chunks) process-login-chunks
] unless ; ] unless ;
: handle-login-packet ( -- ) : handle-login-packet ( -- )
(process-login-chunks) ; FAMILY: 17 OPCODE: 3 process-login-chunks ; FAMILY: 17 OPCODE: 3
: (password-md5) ( password -- md5 ) : password-md5 ( password -- md5 )
login-key get login-key get
password get string>md5 append password get string>md5 append
client-md5-string append client-md5-string append
@ -276,7 +266,7 @@ SYMBOL: message
! password hash chunk ! password hash chunk
HEX: 25 >short HEX: 25 >short
HEX: 10 >short HEX: 10 >short
(password-md5) % password-md5 %
HEX: 4c >short HEX: 4c >short
HEX: 00 >short HEX: 00 >short
@ -297,7 +287,6 @@ SYMBOL: message
head-short head-string login-key set head-short head-string login-key set
respond-login-key-packet ; FAMILY: 17 OPCODE: 7 respond-login-key-packet ; FAMILY: 17 OPCODE: 7
: handle-packet ( packet -- ) : handle-packet ( packet -- )
<string-reader> <string-reader>
[ [
@ -315,8 +304,6 @@ SYMBOL: message
unscoped-stream get empty? [ incomplete-opcode ] unless unscoped-stream get empty? [ incomplete-opcode ] unless
] with-unscoped-stream ; ] with-unscoped-stream ;
! Commands ! Commands
: send-im ( name message -- ) : send-im ( name message -- )
message set message set
@ -391,10 +378,10 @@ SYMBOL: message
message get % message get %
] send-aim ; ] send-aim ;
: (buddy-list-edit-start) : buddy-list-edit-start
[ HEX: 13 HEX: 11 0 HEX: 11 ] send-aim ; [ HEX: 13 HEX: 11 0 HEX: 11 ] send-aim ;
: (buddy-list-edit-stop) : buddy-list-edit-stop
[ HEX: 13 HEX: 12 0 HEX: 12 ] send-aim ; [ HEX: 13 HEX: 12 0 HEX: 12 ] send-aim ;
@ -403,7 +390,7 @@ SYMBOL: message
: add-buddy ( name group -- ) : add-buddy ( name group -- )
name set name set
(buddy-list-edit-start) buddy-list-edit-start
[ [
HEX: 13 8 0 HEX: 57e60008 HEX: 13 8 0 HEX: 57e60008
name get length >short name get length >short
@ -413,9 +400,9 @@ SYMBOL: message
0 >short 0 >short
0 >short 0 >short
] send-aim ] send-aim
(buddy-list-edit-stop) ; buddy-list-edit-stop ;
! : (modify-buddy) ! : modify-buddy
! [ ! [
! HEX: 13 9 0 HEX: 56ef0009 ! HEX: 13 9 0 HEX: 56ef0009
! group length ! group length
@ -424,7 +411,7 @@ SYMBOL: message
: delete-buddy ( name group -- ) : delete-buddy ( name group -- )
name set name set
(buddy-list-edit-start) buddy-list-edit-start
[ [
HEX: 13 HEX: a 0 HEX: 60c0000a HEX: 13 HEX: a 0 HEX: 60c0000a
name get length >short name get length >short
@ -434,8 +421,8 @@ SYMBOL: message
0 >short 0 >short
0 >short 0 >short
] send-aim ] send-aim
! (modify-buddy) ! modify-buddy
(buddy-list-edit-stop) ; buddy-list-edit-stop ;
! Login ! Login
: send-first-login ( -- ) : send-first-login ( -- )
@ -566,8 +553,8 @@ SYMBOL: message
second-server [ handle-loop ] in-thread ; second-server [ handle-loop ] in-thread ;
: run ( username password -- ) : run ( username password -- )
initialize connect-aim ; initialize-aim connect-aim ;
! [ initialize connect-aim ] with-scope ; ! [ initialize-aim connect-aim ] with-scope ;
! my aim test account. you can use it. ! my aim test account. you can use it.
: run-test-account : run-test-account