;; sula-boot-0.36a,  1Sep99
;; ************************************
;; * Rename this file to "sula-boot". *
;; ************************************
;; This is the boot file for Sula Primerix. By default, Program will look for
;; it under /usr/local/lib/sula. Its location may also be specified using the
;; entry Sula.Sula-boot: in an X resource file. Or by using command line option
;; -bootlocation.
;; See the sample X resource file sula.app-defaults or
;; /usr/lib/X11/app-defaults/Sula for a list of other entries.
;;
;; Updated versions of this file will be found where you got Sula PrimeriX,
;; especially at the following locations:
;;    http://spx.linuxatwork.at/download
;;    http://www.geocities.com/SiliconValley/Bit/1962/download
;;    
;;
;; Copyright (C) 1998,1999 Tano Fotang, fotang@yahoo.com    
;; 
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; 
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;; 
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;;

(define *gtk* (and(defined? '*gui*)(equal? *gui* "gtk")))
(define *xforms* (and(defined? '*gui*)(equal? *gui* "xforms")))

;;----------------------
;; Obsolete. Do not use.
;s-print
;s-write
(define gs-clear-main-window gs-clear-console)
(define (sx-dialog data proc . rest) (apply sx-dialog-new data proc #f rest))
(define (sx-text-label! w str) (sx-text-set! w 'label str))
(define sx-text-destroy sx-tb-destroy)
(define sx-text-set! sx-tb-set!)
;;end of obsolete
;;----------------------

(define TRUE #t)
(define FALSE #f)

;; SkriptX
;;------------------------------
;;these ones for backward compatibility
(define (sx-submit path proc . args) (apply sx-submit-new #f path proc args))
(define (sx-console-submit path proc . args)
  (apply sx-submit-new #t path proc args))
(define (sx-remove-path path)(sx-menuitem-remove #f path))
(define (sx-clear-menu)(sx-menu-clear #f))

(define (sx-text-new w h . args)(apply sx-tb-new #t w h 0 #f args)) 
(define sx-text-clear sx-tb-clear)
(define (sx-text-add-text i str)(sx-tb-add-line i str #t))
(define sx-text-destroy sx-tb-destroy)
(define (sx-clist-new w h ncols . args) (apply sx-tb-new #f w h ncols #t args))
(define (sx-sclist-new w h ncols . args) (apply sx-tb-new #f w h ncols #f args))
(define (sx-clist-add-rows id items)(sx-tb-add-line id items #f))
(define sx-clist-clear sx-tb-clear)
(define (sx-get-selected-rows id) (sx-clist-get-selection id #t))
(define (sx-get-selected-text id) (sx-clist-get-selection id #f))
(define (sx-clist-titles-hide id) (sx-clist-titles-hide/show id #t))
(define (sx-clist-titles-show id) (sx-clist-titles-hide/show id #f))
(define (sx-delete-selected-rows id)(sx-clist-delete-rows id))
(define (sx-delete-rows id rows)(sx-clist-delete-rows id rows))
(define sx-clist-destroy sx-tb-destroy)


;; -- Misc. string functions --

;; return start pos of n'th word
;; if(n<0) n=0. if(n>word_count) n=word_count 
;; n==strlen(s) means n>word count.
(define word-index gs-word-index)

(define (string-rest s n)
;; return s starting from the n'th word
;; (string-rest  "  this is ab bad te sst" 3)==>"bad te sst"
  (make-shared-substring s (word-index s n)))

(define (string-start s n)
;; return s up to the n'th word
;; (string-start  "  this is ab bad te sst" 3)==>"  this is ab "
  (make-shared-substring s 0 (word-index s n)))

;; Returns the nth word of a string sans-surrounding-whitespaces. n>= 0
;; E.g. (next-word " This is  a test     " 3) --> "test"
(define next-word gs-word-next)

;; returns a string containing the result of printing its arguments.
;; (gs-display display display " is not write " write)
;;  ==>"#<primitive-procedure display> is not write #<primitive-procedure write>"  
(define gs-display (lambda x (call-with-output-string
  (lambda(n) (for-each (lambda(i) (display i n)) x)))))
(define display2string gs-display)
;; obsolete:
;(define s-display gs-display);obsolete 3/99
;(define s-print s-display);obsolete 3/99

(define gs-write (lambda x (call-with-output-string
  (lambda(n) (for-each (lambda(i) (write i n)) x)))))
(define write2string gs-write)
;(define s-write gs-write);obsolete 3/99

(define _say (lambda (w . x)
  (gs-echo (call-with-output-string (lambda(n)
    (for-each (lambda(i) (display i n)) x)))  w)))
(define _say2 (lambda (w . x)
  (gs-echo (call-with-output-string (lambda(n)
    (for-each (lambda(i) (display i n)) x)))  w 1)))
(define say (lambda args
  (gs-echo (call-with-output-string (lambda(n)
    (for-each (lambda(i) (display i n)) args))))))


;(define (gs-display proc . args) (call-with-output-string
;  (lambda(outport)
;    (let loop ((rest args))
;      (cond
;        ((null? rest) (proc rest outport))
;        ((null? (cdr rest)) (proc (car rest) outport))
;        (else
;          (proc (car rest) outport)
;          (proc " " outport)
;          (loop (cdr rest))))))))


;; Error handler.. who need it?
(define (gs-handler key args . rest)
   (define errstr (call-with-output-string (lambda(n)
     (let*((str (car rest))(len (string-length str)))
     (let loop ((pos 0)(l (cadr rest))(ok #f))
       (cond
         ((= pos len)(display "." n))
         ((eq? ok #t)
           (cond
             ((equal? #\S (string-ref str pos))
               (write (car l) n)
               (loop (1+ pos) (cdr l) #f))
             ((equal? #\s (string-ref str pos))
               (display (car l) n)
               (loop (1+ pos) (cdr l) #f))
             (else
               (display "%" n)
               (loop (1+ pos) l #f)))) 
         ((equal? #\% (string-ref str pos))
           (loop (1+ pos) l #t))
         (else
           (display (string-ref str pos) n)
           (loop (1+ pos) l #f))))))))
   (if args
      (gs-echo (gs-display "@f" key ": [" args "] " errstr))
      (gs-echo (gs-display "@f" key ": " errstr))))
  

(define uniq-list(lambda (l)
;; takes a list and removes duplicate members
  (let((tmp '()))
     (for-each (lambda(i)
         (if(not (memq i tmp)) (set! tmp (append (list i) tmp)))) l)
     tmp)))
(define uniqfy-list uniq-list)
   
;; -- Misc. procedures ---

;; return nick, given nick!user@host
(define (sender2nick sender)
   (define pos (string-index sender #\!))
   (if pos (make-shared-substring sender 0 pos) sender))

;; return user@host, given nick!user@host
(define (sender2userhost sender)
   (define pos (string-index sender #\!))
   (if pos (make-shared-substring sender (1+ pos)) sender))
   
;; -- Convenience procedures based on sula primitives --
(define gs-new-alarm gs-alarm)
(define gs-timer gs-alarm)
(define gs-new-clock gs-clock)

; H o o k s
(define (gs-shell-hook type pat . rest) (apply gs-new-hook type #f #f #f pat rest))
(define (gs-ishell-hook type pat . rest) (apply gs-new-hook type #f #t #f pat rest))
(define (gs-regex-hook type pat . rest) (apply gs-new-hook type #f #f #t pat rest))
(define (gs-iregex-hook type pat . rest) (apply gs-new-hook type #f #t #t pat rest))

(define gs-add-hook gs-ishell-hook)
(define gs-on gs-ishell-hook) ;; gs-on is obsolete

(define (gs-shell-preempt type pat . rest) (apply gs-new-hook type #t #f #f pat rest))
(define (gs-ishell-preempt type pat . rest) (apply gs-new-hook type #t #t #f pat rest))
(define gs-preempt gs-ishell-preempt)
(define (gs-regex-preempt type pat . rest) (apply gs-new-hook type #t #f #t pat rest))
;; compile regex to ignore case
(define (gs-iregex-preempt type pat . rest) (apply gs-new-hook type #t #t #t pat rest))

(define (gs-delete-hook type . args)
; gs-delelete-hook [#]type [numeric] pattern
  (gs-exec (apply gs-display "/on -del " type " " args) -1))
(define (gs-delete-preempt type . args)
  (gs-remove-preempt (apply gs-display type " " args)))
  
(define (gs-command? str) (gs-valid-comand? str #t))
(define (gs-ctcp-command? str) (gs-valid-comand? str #f))
(define (gs-delete-command str)(gs-remove-command str #t))
(define (gs-delete-ctcp-command str)(gs-remove-command str #f))

(define (servers-socket-fd)
;; returns a list of unique pairs (socket_fd . nick) each containing
;; the socket descriptor and your nick for each server connection.
;; (the length of the list is the number of existing server connections.)

   (define win-list (gs-window-list))
   (define tmp '())
   (for-each
      (lambda(i)
         (define server (gs-window-server2 i))
         (if(and (not(null? server)) (server:connected? server))
            (set! tmp (append (list(cons (server:fd server) (server:nick server))) tmp))))
      win-list)
   (uniqfy-list tmp))    
       

;(gs-execute window args
;(gs-execute -1 "echo " (getenv "USER") sin 12)
(define gs-execute (lambda (w . args)
 (gs-exec (call-with-output-string
  (lambda(n) (for-each (lambda(i) (display i n)) args))) w)))
(define (gs-execute0 args) (gs-execute -1 args))

;; Colours. Define indices 8 to 15
(gs-parse-colour "rgb:40/130/78") ; slateblue
(gs-parse-colour "rgb:69/69/69")  ; dimgray
(gs-parse-colour "rgb:5f/9e/a0")  ; cadetblue
(gs-parse-colour "rgb:98/fb/98")  ; palegreen
(gs-parse-colour "rosybrown")
(gs-parse-colour "lightpink")
(gs-parse-colour "plum")
(gs-parse-colour "mediumpurple")
  
(define (gs-client-name) (vector-ref *sula-version* 0))
(define (gs-major-version) (vector-ref *sula-version* 1))
(define (gs-minor-version) (vector-ref *sula-version* 2))
(define (gs-revision) (vector-ref *sula-version* 3))  
(define gs-version (lambda() (vector-ref *sula-version* 4)))
(define (gs-release) (vector-ref *sula-version* 5))

(define *sula-random-string* (make-shared-substring sula-random-string 0))

(define (force-window-kill w) (gs-kill-window w #t))
;; Total number of channel windows
(define window-count (lambda() (length(gs-window-list))))

;; Is w a valid window number?
(define window-valid? (lambda(w) (if(not (memq w (gs-window-list))) #f #t)))

;;;;;;;;;;;;;;;;;;;;  DCC LIST  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;(gs-dcc-list)
;;Returns a list of all DCC items. It is similar to /DCC list.
;;Each item is a vector. The following procedures accept such a DCC 
;;item and return selected components.

;; is this a DCC CHAT item or a DCC file transfer item?
(define (dcc:chat? dcc) (vector-ref (vector-ref dcc 0) 0))
(define (dcc:file? dcc) (not (dcc:chat? dcc)))

;; is DCC item in active state (not queued)?
(define (dcc:active? dcc) (vector-ref (vector-ref dcc 0) 1))
(define (dcc:queued? dcc)(not(dcc:active? dcc)))

;; did we receive the DCC chat/file offer, or did we send it?
(define (dcc:sent? dcc) (vector-ref (vector-ref dcc 0) 2))
(define (dcc:received? dcc) (not(dcc:sent? dcc)))

;; been forwarded to somebody?
(define (dcc:forwarded? dcc) (vector-ref (vector-ref dcc 0) 3))

;; the ID of the item (a number). Instead of /dcc get foo bar.txt,
;; one can use the ID and say /dcc get id
(define (dcc:id dcc)(vector-ref dcc 1))

;; the person at the other end
(define (dcc:nick dcc)(vector-ref dcc 2))
;; their user@home.dom
(define (dcc:userhost dcc)(vector-ref dcc 6))

;; when the item was created (seconds since 00001970
(define (dcc:starttime dcc)(vector-ref dcc 3))

;; how many have we sent or received?
(define (dcc:bytes-sent dcc)(vector-ref dcc 4))
(define (dcc:bytes-received dcc)(vector-ref dcc 5))

;; if the item is still queued, we can obtain the 32 bit address internet
;; address (sin_addr). The hostname is inet_ntoa(htonl(this-address))
(define (dcc:remote-addr dcc)(if(dcc:queued? dcc) (vector-ref dcc 7) #f))
;; if connection is already active, we get the IP number instead:
(define (dcc:remote-IP dcc)(if(dcc:active? dcc) (vector-ref dcc 7) #f))

;; the remote port for this item
(define (dcc:remote-port dcc)(vector-ref dcc 8))
(define (dcc:window dcc)(vector-ref dcc 9))
;;The following are only defined for DCC file transfers, they don't
;;apply to DCC chat.
(define (dcc:file-name dcc)(if(dcc:file? dcc) (vector-ref dcc 10) #f))
(define (dcc:file-size dcc)(if(dcc:file? dcc) (vector-ref dcc 11) #f))
(define (dcc:file-checksum dcc)(if(dcc:file? dcc) (vector-ref dcc 12) #f))

;;;;;;;;;;; end of DCC list ;;;;;;;;;;;;,;

;;;;;;; DCC chat in a window ;;;;;;;;;;;;
;; (gs-window-chat [window-number])
;;    Returns a list of DCC chat objects on a window.
;;    A DCC chat object is a vector with the following members respectively:
;;    window number,socket descriptor, nick name, user@host (might be #f),
;;    dotted numeric IP of remote host, byte count read so far from the DCC,
;;    number of bytes written.
(define (chat:id chat)(vector-ref chat 1))
(define (chat:window c)(vector-ref c 0))
(define (chat:fd c)(vector-ref c 2))
(define (chat:nick c)(vector-ref c 3))
(define (chat:userhost c)(vector-ref c 4))
(define (chat:IP c)(vector-ref c 5))
(define (chat:read c)(vector-ref c 6))
(define (chat:written c)(lvector-ref c 7)) 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define channel-last-parted (lambda win (apply gs-last-channel #f win)))
(define channel-last-joined (lambda win (apply gs-last-channel #t win)))
;(define gs-last-joined channel-last-parted); obsolete Apr1 99
;(define gs-last-parted channel-last-parted); obsolete Apr1 99

;; (gs-channel [channel-name [window-number]])
;; Returns a channel object.
;; (gs-window-channels) returns a list of channel objects.
;;e.g.
;;(define channel (gs-channel "#test"))
;;(define channel (gs-channel "#test" 1))
;; A channel object may be passed to the following procedures.

;; case-sensitive channel name.
;; This is the real name as known by the IRC server.
        (define (channel:name channel) (list-ref channel 1))
	
;; on which server is the channel? (Note:this returns the same object
;; as (gs-window-server ....)
	(define (channel:server channel)(gs-window-server (car channel)))

;; on what window is channel?
        (define (channel:window channel)(car channel))
	
;; what are the channel modes?
	(define (channel:modes channel) (list-ref channel 2))
	
;; am i channel op?
	(define (channel:op? channel)    
	    (if(or (not(channel:modes channel))
	    (not(string-index (channel:modes channel) #\o)))
	    #f #t))
	    
;; can i speak on channel?
        (define (channel:voice? channel)    
	    (if(or (not(channel:modes channel))
	    (not(string-index (channel:modes channel) #\v)))
	    #f #t))
	    
;; channel limit?
	(define (channel:limit channel) (list-ref channel 3))
	
;; channel key?
	(define (channel:key channel)   (list-ref channel 4))
	
;; channel topic?
	(define (channel:topic channel) (list-ref channel 5))
	
;; Update user list
(define (update-user-list channel)
   (gs-exec (string-append "who -update " (channel:name channel)) (
   channel:window channel)))

;; (gs-channel-users)
;; (gs-channel-users channel_name)
;; (gs-channel-users channel_name window-number)
;;
;; These procedures return user objects. A user object a list object
;; representing a user on a channel.
;; (user) = (window_nr channel_name nick modes email_address irc_name)
;; Example:
;; (define users (gs-channel-users)) ; current channel
;; (define users (gs-channel-users "#test"))
;; (define users (gs-channel-users "#test" 0))

;; Let <user> be one user on the channel, e.g. (define user(car users)).
;; Then each of the following procedures accept the user object.

(define (user:window user)(list-ref (cdr user) 4))
(define (user:channel user)(list-ref (cdr user) 3))
(define (user:nick user)(car user))
(define (user:modes user)(list-ref (cdr user) 0))
(define (user:address user)(list-ref (cdr user) 1))
(define (user:irc-name user)(list-ref (cdr user) 2)) ;if this returns #f,
; update channel user list using,for example,
; (update-user-list (gs-channel (user:channel user) (user:window user))) 
  

;; The server object was either returned by (gs-window-server)
;; or by (channel:server)
;; E.g. (define server (gs-window-server w))

;;socket descriptor
(define (server:fd server)(car server))
;does a connection exist to the server?
(define (server:connected? server)(if(> (car server) -1) #t #f)) 

(define (server:nick server)(list-ref server 3))
(define (server:irc-name server)(list-ref server 4))
(define (server:modes server)(list-ref server 5)) ;; what is this??
;; alias was the argument to /server command
(define (server:alias server)(cadr server))
;; name is the server to which you got connected. name is not always of
;; the same value as alias. E.g. alias=irc.dal.net but name=voyager.CA.us.dal.net.
(define (server:name server)(list-ref server 7))
(define (server:port server)(list-ref server 2))
;; channel last invited to
(define (server:last-invite server)(list-ref server 8))
;am I marked as being away?
(define (server:away? server)(list-ref server 9))
;; Bytes read from server so far
(define (server:read server)(list-ref server 10))
;; Bytes read from server so far
(define (server:wrote server)(list-ref server 11))
;; when was connection established
(define (server:start-time server)(list-ref server 12))
;; nickname group
(define (server:nickgroup server)(list-ref server 13))
(define (server:nickgroup! server group)(gs-server-nickgroup! server group))

;;----------the keybinding script----------------------------
;;
;;  keybinding.scm - A FRIENDLY INTERFACE TO KEY BINDING
;;  This script provides a friendly, albeit limited, interface to sula
;;  key binding  procedures.
;;
;; Usage:
;;  (bind-key <key-mask> <procedure>)
;;  (delete-key-binding <key-mask>)
;;  (list-key-bindings)
;;  (key-binding->str <binding>)
;;  (string->key-binding <key-mask>)
;;  
;; See keybinding.doc for details.
;;
;; bind Examples:
;;  (bind-key "Alt+i" (lambda(window char state)
;;  	  (gs-set-input "hello world" window)))  
;;  (bind-key "Alt+Control+q" (lambda(a b c)(gs-exec "exit" -1)))
;;  (bind-key "Button1+Shift_L" (lambda(window char mask)
;;  	(gs-echo "You pressed mouse button 1 and shift_left" window)))
;;  (delete-key-binding "Alt+i")
;;  (key-binding->str '(q 517)) ==>SHIFT+CONTROL+BUTTON2+q
;;  (string->key-binding "SHIFT+CONTROL+BUTTON2+q") ==>(q . 517)


(define Modifiers '((SHIFT  	#b1)	    	    ;ShiftMask
    	    	    	  (LOCK   	#b10)     	    ;LockMask
						        (CONTROL	#b100)    	    ;ControlMask
                    (CTRL   	#b100)
						        (MOD1   	#b1000)   	    ;Mod1Mask
						        (ALT    	#b1000)   	    ;xev(1) shows Mod1
						        (MOD2   	#b10000)  	    ;Mod2Mask
						        (MOD3   	#b100000) 	    ;Mod3Mask
						        (MOD4   	#b1000000)	    ;Mod4Mask
						        (MOD5   	#b10000000)     ;Mod5Mask
						        (BUTTON1	#b100000000)    ;Button1Mask
						        (BUTTON2	#b1000000000)   ;Button2Mask
						        (BUTTON3	#b10000000000)      ;Button3Mask
    	    	        (BUTTON4	#b100000000000)     ;Button4Mask
						        (BUTTON5	#b1000000000000)))  ;Button5Mask
						 
;; takes (keysym . state) and returns correspondig string
(define (key-binding->str binding)
  (define str "")
  (define state 0)
  (for-each
	 (lambda(mask)
		(if(and (not(= 0 (logand (cadr mask)(cadr binding))))
		    	  (= 0 (logand state (cadr mask))))
    	   (begin
			 (set! str (string-append str (car mask) "+"))
			 (set! state (logior (cadr mask) state)))))
	 Modifiers)
  (string-append str (car binding)))
	 
;; take a key mask (e.g,control+alt..+a) and return the pair (keysym . state)
(define (string->key-binding str)  
  (call-with-current-continuation (lambda(return)		  		  
		(let*((key-mask (reverse (separate-fields-discarding-char #\+ str list)))  
		(c (car key-mask))
    (state 0))
		(set! key-mask (cdr key-mask))
		(for-each
   	  (lambda(mask)	   	   
			 (define key (assq (string->symbol(string-upcase! (string-copy
				 mask))) Modifiers))			 
	   	 (if(not(eqv? #f key))
				(set! state (logior (cadr key) state))
				(begin
				  (gs-echo (gs-display "Unknown modifier in \"" str "\". (stop at \""
				    mask "\")") -1)
			  
				  ;;(scm-error 'unknown-modifier "string->key-binding"
				  ;;"Invalid keymask: %S. (stop at %S)" (list str mask) #f)

    	    	(return #f))))   
		  key-mask)
		(cons c state)))))
		

;; display all user-defined key bindings to stdout
(define (list-key-bindings)
  (define bindings (gs-query-key-bindings))
  (display "\nCurrent user-defined key bindings\n")
  (display "---------------------------------\n")
  (for-each
    (lambda(binding)
	 	(display (key-binding->str binding))(newline))
	 bindings))	 

;; create a key binding
(define (bind-key str . proc)
  (define binding (string->key-binding str))	
  (if(eqv? #f binding) #f
    (apply gs-bind-key (car binding) (cdr binding) proc)))

;; remove a key binding	 
(define (delete-key-binding str)
  (define binding (string->key-binding str))	
  (if(eqv? #f binding) #f
    (gs-delete-key-binding (car binding) (cdr binding))))

;; ---------end of keybinding script---------  

; connect to a server. To be used with the xforms version of SPX
; instead of (gs-exec "server "....).
; We check to see if any windows are available. If there are, we connect
; using the first window that isnt connected. Otherwise, we create a new
; window and try again.
; Arguments:
; to  : server name
; arg : [port [nick [pass]]] (optional)
; port defaults to 6667; nick, to getenv("IRCNICK" or "USER").
; E.g. (server "irc.eskimo.com")
(define (server to . arg)
(let ((window -1))
  (if *xforms*
    (set! window (let repeat ((wl (gs-window-list)))
      (if(null? wl)
        #f
        (let ((s (gs-window-server (car wl))))
          (if(or (null? s) (not(server:connected? s)))
            (car wl)
            (repeat (cdr wl))))))))
  (if(not window)
    (let()
	    (gs-create-window)
      (gs-new-alarm 2 (lambda(bla blah)(apply server to arg))))
    (let ((p (make-vector 3 #f))(nick (getenv "IRCNICK"))
          (the-cmd #f)) ; /server name port -nick nick -pass pass
       (vector-set! p 0 6667)
       (vector-set! p 1 (if nick nick (getenv "USER")))
       (let loop ((i 0)(args arg))
          (if(and(not(null? args))(< i 3))
            (begin
              (vector-set! p i (car args))
              (loop (1+ i) (cdr args)))))
       (if (vector-ref p 2)
          (set! the-cmd (display2string "/server " to " " (vector-ref p 0)
           " -nick " (vector-ref p 1) " " (vector-ref p 2)))
          (set! the-cmd (display2string "/server " to " " (vector-ref p 0)
           " -nick " (vector-ref p 1))))
       (gs-exec the-cmd window)))))
;; ---end of server------

;; this pocedure connects to a server and automatically joins the given
;; channel. port is either numeric or #f.
;; if you're already connected to the server, it just joins the channel.
;; Usage: (connect-and-join servername port channel [key])
;; e.g. (connect-and-join "irc.undernet.org" #f "#irchelp")

(define (connect-and-join servrname port ch . key)
 (call-with-current-continuation (lambda(return)
 (let*(
   (pass (if(not(null? key)) (car key) ""))
   (window (let loop((wl (gs-window-list))(prev -1))
     (if(null? wl)
       prev
       (let* ((win (car wl))(s (gs-window-server win)))
         (if(and(not(null? s))
                 (string-ci=? servrname (server:name s))
                 (or(not port)(= port (server:port s))))
           (if(server:connected? s)
              (return (gs-execute win "/join " ch " " pass)))
              win)
           (loop (cdr wl) (if(or(null? s)(not(server:connected? s)))
              win prev))))))
   (serial (- (gs-srandom #t)));; random serial number
   (pattern (display2string servrname "," (if port port "") "*")))
   (gs-add-hook "#001" serial pattern (lambda(m win)
     (gs-execute win "/join " ch " " pass)
     (gs-delete-hook "#001" serial " "pattern)
     (gs-delete-hook "#server_failed" serial " " pattern)))
   (gs-add-hook "#server_failed" serial pattern (lambda(m win)
     (gs-delete-hook "#001" serial " "pattern)
     (gs-delete-hook "#server_failed" serial " "pattern)))
   (gs-execute window "/server " servrname " " (if port port ""))))))
;;---end of connect-and-join------------------
   
;; --process user messages from a server----
;; The following procs take a message and returns specific components.
;; Of course it doesn't apply to server numeric replies!!
;; Message if the form "<servername>,<port> <message>".

;; the name of the IRC server
(define ($server m) (make-shared-substring m 0 (string-index m #\,)))

;; the connection port
(define ($port m)  (let ((s (next-word m 0)))
  (string->number (make-shared-substring s (1+ (string-index s #\,))))))
  
;; the nickname of the sender
(define ($nick m) (let ((from (next-word m 1)))
  (make-shared-substring from 0 (string-index from #\!))))

;; user@host.domain of sender
(define ($userhost m) (let ((from (next-word m 1)))
  (make-shared-substring from (1+ (string-index from #\!)))))

;; destination of the message; doesnt apply to raw_irc
(define ($dest m) (next-word m 2))

;; the message; doesnt apply to raw_irc
(define ($msg m) (string-rest m 3))

;; --end of user message procs--
;; aliases

(gs-exec "/alias list /quote list $1-")
(gs-exec "/alias names /quote names $1-")
(gs-exec "/alias admin /quote admin $1-")
(gs-exec "/alias oper /quote oper $1-")
(gs-exec "/alias silence /quote silence $1-")
(gs-exec "/alias cd (if(not(string-null? \"$1-\")) (chdir \"$1-\"))(getcwd)")
(gs-exec "/alias news (gs-execute $_ \"/window --load 1 --file \" *sula-libdir* \"/WHATSNEW\")")

;add $libdir/trill and ~/.sula/trill to module path:
(set! %load-path (append (list  (string-append *sula-home* "/.sula/trill")
                                (string-append *sula-libdir* "/trill"))
                         %load-path))

(catch #t
    (lambda()
      (let ((news (string-append *sula-libdir* "/WHATSNEW"))
            (news0 (string-append *sula-home* "/WHATSNEW")))
        (if(not(access? news R_OK)) (set! news "./conf/WHATSNEW"))
        (if(access? news R_OK)
          (let((buf (stat news))(buf0 #f)(show-it #f))
            (if(not(access? news0 F_OK))(begin (set! show-it #t)
                (system (string-append "/usr/bin/touch " news0))))
            (if(access? news0 R_OK) (set! buf0 (stat news0)))
            (if(not show-it)
              (set! show-it (or (not buf0)
                            (< (stat:mtime buf0)(stat:mtime buf)))))
            (if show-it
              (let((_w (sx-text-new 500 250
                         SX_PIXMAP (string-append *sula-libdir* "/pixmaps/spx-mini.xpm"))))
                  (system (string-append "/usr/bin/touch " news0))
                  (sx-text-set! _w  'title (string-append "Welcome to "(gs-client-name)
                      "! What is new? [" (gs-version) "]"))
                  (sx-text-set! _w 'bg-colour "black" )
                  (sx-text-set! _w 'fg-colour "white" )
                  ;;(sx-text-add-text _w "@C4@lWhat is new\n")
                  (sx-text-add-file _w news)))))))
      gs-handler)

;; load some modules
(catch #t (lambda() (use-modules (string util))) gs-handler)

(set! sula-boot-no-error #t)

;EOF
