;; sula-boot 0.2
;; Valid as of sula 0.04.2.
;;
;; Updated versions of this file will be found where you got sula,
;; especially at http://www.geocities.com/SiliconValley/Peaks/8771/download
;;
;; This is the boot file for gsula.
;; The system initialisation file gsularc will be read after this,
;; followed by private stuff from ~/.gsularc.
;;
;;
;; Copyright (C) 1998 Tano Fotang     
;;
;; 
;; 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
;; 

;; The procedure separate-fields-discarding-char is taken from the
;; file guile/1.3.1/ice-9/string-fun.scm that comes with guile.
;; It is included here because some sula script examples use it and
;; some people just can't/won't (use-module (ice-9 string-fun))!
(define (separate-fields-discarding-char ch str ret)
  (let loop ((fields '())
             (str str))
    (cond
     ((string-rindex str ch)
      => (lambda (w) (loop (cons (make-shared-substring str (+ 1 w)) fields)
                           (make-shared-substring str 0 w))))
     (else (apply ret str fields)))))

;; -- Misc. procedures ---


(define (do-nothing arg1 arg2) #t)
       
(define s-display (lambda x (call-with-output-string
  (lambda(n) (for-each (lambda(i) (display i n)) x)))))
(define s-print s-display)
(define s-write (lambda x (call-with-output-string
  (lambda(n) (for-each (lambda(i) (write i n)) x)))))
 
(define uniqfy-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)))
     
;; -- Procedures based on sula primitives --
(define gs-new-alarm gs-alarm)
(define gs-new-clock gs-clock)
(define (connect to port nick)
;; connect to server <to> using nick.
;; use this proc instead of (gs-exec "server ...")
;; you may add password to parameter list and then modify the gs-exec call.
     (if(null? (gs-window-list))
       (let()
	  (gs-create-window)
          (gs-alarm 3 (lambda(a b)(connect to port nick))))
       (gs-exec (s-display "server " to " " port " -nick " nick))))	 
 

(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-server 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))    
       
;; Total number of windows currently open
(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)))

;; (gs-window-dcc [window-number])
;;    Returns a list of DCC chat objects on a window.
;;    A DCC chat object is a list 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 (dcc:fd dcc)(car dcc))
(define (dcc:window dcc)(list-ref dcc 6))
(define (dcc:nick dcc)(cadr(cdr(dcc))))
(define (dcc:IP dcc)(list-ref dcc 4))
(define (dcc:read dcc)(list-ref dcc 5))
(define (dcc:written dcc)(list-ref dcc 6)) 


;; (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)(car user))
(define (user:channel user)(cadr user))
(define (user:nick user)(list-ref user 2))
(define (user:modes user)(list-ref user 3))
(define (user:address user)(list-ref user 4))
(define (user:irc-name user)(list-ref user 5)) ;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))

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