scsh-conservatory
/
sunterlib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

scgame and tmail initial commit

This commit is contained in:
Johan Ceuppens 2012-01-16 16:22:48 +00:00
parent 02699e0409
commit 2e23e8ba30
27 changed files with 1248 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
scsh/scgame/AUTHORS Normal file
View File

@ -0,0 +1 @@
Copyright (C) 2011-2012 Johan Ceuppens

1
scsh/scgame/BLURB Normal file
View File

@ -0,0 +1 @@
scgame : a Carbon library (drawing and widgets)

2
scsh/scgame/NEWS Normal file
View File

@ -0,0 +1,2 @@
version 0.1
* line drawing algorithm and xanadu file system

1
scsh/scgame/README Normal file
View File

@ -0,0 +1 @@
scgame is a drawing package and should be useful to make widgets

9
scsh/scgame/packages.scm Normal file
View File

@ -0,0 +1,9 @@
(define-interface scgame-interface
(export
make-scgame))
(define-structure scgame
scgame-interface
(open scheme)
(files scgame))

17
scsh/scgame/pkg-def.scm Normal file
View File

@ -0,0 +1,17 @@
(define-package "scgame"
(0 1)
((install-lib-version (1 3 0)))
(write-to-load-script
`((config)
(load ,(absolute-file-name "packages.scm"
(get-directory 'scheme #f)))))
(install-file "README" 'doc)
(install-file "NEWS" 'doc)
(install-string (COPYING) "COPYING" 'doc)
(install-file "packages.scm" 'scheme)
(install-file "scgamedictionaries.scm" 'scheme)
(install-file "scgameutil.scm" 'scheme)
(install-file "scgamewidgets.scm" 'scheme)
(install-file "scganadu.scm" 'scheme)
(install-file "scganaduutil.scm" 'scheme)
(install-file "scgame.scm" 'scheme))

179
scsh/scgame/scgame.scm Normal file
View File

@ -0,0 +1,179 @@
;;; scgame.scm - a scheme game library
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(load "scgameutil.scm")
(load "scgamedictionaries.scm")
;; interface 1
(define (make-scdraw1) (lambda (msg) (aspecterror)(display "make-scdraw1")))
(define (make-scimage1) (lambda (msg) (aspecterror)(display "make-scimage1")))
;; interface 2
(define (coolness? x) (not (null? x))) ;; coolness
(define (make-scdraw2)
(define (draw-line x0 y0 x1 y1 . w) ;; FIXME w == line width
(let ((width (if (coolness? w)(if (number? (car w)) (car w) 1))))
(display "FIX drawing line...")
;;FIXME This should be Bresenham
(let ((steep (> (abs (- y1 y0))
(abs (- x1 x0))))
(swap (lambda (x y)
(list y x)))
(range (lambda (x y)
(let ((l '()))
(cond ((< x y)
(do ((i x (+ i 1)))
((= x y) l)
(set! l (append l (list i)))))
((< y x)
(do ((i y (+ i 1)))
((= y x) l)
(set! l (append l (list i)))))
(else (display "range : x == y")
x)))))
)
(if steep
(let ((t (swap x0 y0))
(x0 (car t))
(y0 (cadr t)))
(let ((deltax (- x1 x0))
(deltay (abs (- y1 y0))))
(let ((error (/ delta 2))
(ystep 0)
(y y0))
(if (< y0 y1)
(+ ystep 1)
(- ystep 1)
(for-each (if steep
(putpixel y x 254)
(putpixel x y 254))
(set! error (- error deltay))
(if (< error 0)
(set! y (+ y ystep))
(set! error (+ error deltax)))
(range x0 x1))
))))))))
(define (draw-lines l1 . w)
(display "FIX drawing lines...")
(for-each draw-line l1)
)
(lambda (msg)
(cond ((eq? msg 'draw-line)draw-line)
(else (aspecterror)(display "scdraw2"))))
))
;; color table out of xpm pre
(define (make-color-table)
(let ((dict (make-dictionary)))
(define (add! key color)
(dictionary-add! dict key color))
(define (set! key color)
(dictionary-set! dict key color))
(lambda (msg)
(cond ((eq? msg 'add!) add!)
((eq? msg 'set!) set!)
(else (dict msg))))
))
(define (make-scimage2)
(let ((*db (make-dictionary)))
;; private methods
(define (load-xpm-image filename)
(let ((in (open-input-file filename))
(colorcharsdictionary (make-color-dictionary 8)) ;;
(colorcharstable (make-color-table))
)
(do ((str (read in) (read in)))
((string<=? "{" str)#t))
(do ((chr (read-char in) (read-char in)))
((eq? #\" chr)#t))
(let ((width (read in))
(height (read in))
(number-of-colors (read in))
)
(do ((chr (read-char in) (read-char in)))
((eq? #\, chr)#t))
(do ((n1 number-of-colors (- n1 1)))
((<= n1 0)#t)
(do ((chr (read-char in) (read-char in)))
((eq? #\" chr)#t))
(let* ((colorchar (read-char in))
(colorcharnumber (string->number (string colorchar)))
)
((colorchars 'add!) colorchar colorcharnumber) ;; FIXME color 255 (extra map-dict)
))
;;FIX
)))
;; public methods
(define (load-image filename)
;; FIXME read in xpm or png
(display "loading image...")
(cond ((string<=? ".xpm" filename)
(load-xpm-image filename)
)
(lambda (msg)
(cond ((eq? msg 'load-image)load-image)
(else (aspecterror)(display "scimage2"))))
))
;; Give a #t as arg and have a nice interface
(define (make-scgame . tm)
(cond ((not (null? tm)
(let ((*scdraw (make-scdraw1))
(*scimage (make-scimage1))
)
(lambda (msg)
(cond ((do ((i 0 (+ i 1)))
((substring? "draw-" msg i) (*scdraw msg))))
((do ((i 0 (+ i 1)))
((substring? "image-" msg i) (*scimage msg))))
(else (aspecterror)(display "scgame1"))
))))
)
(else
(let ((*scdraw (make-scdraw2))
(*scimage (make-scimage2))
)
(lambda (msg)
(cond ((eq? msg 'draw-line) (*scdraw msg))
((eq? msg 'draw-lines) (*scdraw msg))
(else (aspecterror)(display "scgame2"))))
))))

276
scsh/scgame/scgamedictionaries.scm Normal file
View File

@ -0,0 +1,276 @@
;;; scgamedictionaries.scm - a scheme dictionary system for scgame
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;; Dictionary ADT with ref,set!,add!,make public methods at the end
(define (make-dictionary1)
;; methods are FIFO (first fixed first out)
(let ((*dict '()))
(define (get key) ;; get key
(do ((l *dict (cdr l)))
((eq? key (caar l))
(cadr l));;returns value
))
(define (add key value)
(set! *dict (append *dict (list (list key value)))))
(define (set key value) ;; get key
(do ((l *dict (cdr l))
(res '() (append (list (car l) res))))
((eq? key (caar l))
(set! (cadr res) value)
(set! *dict (append res (cdr l))))
))
(lambda (msg)
(cond ((eq? msg 'get) get)
((eq? msg 'set) set)
((eq? msg 'add) add)
(else (aspecterror)(display "make-dictionary"))))
))
(define (make-dictionary) (make-dictionary1))
(define (dictionary-ref dict key) ((dict 'get) key))
(define (dictionary-set! dict key value) ((dict 'set) key value))
(define (dictionary-add! dict key value) ((dict 'add) key value))
;; color dictionary - for CSS colors use bpp set to 0
;; helper functions
(define (string->color str)
(let ((colornumber 0))
(do ((i 0 (+ i 1)))
((< i (string-length str)) colornumber)
(let* ((c (string-ref str i))
(n (cond ((or (eq? c #\a)(eq? c #\A))
10)
((or (eq? c #\b)(eq? c #\B))
11)
((or (eq? c #\c)(eq? c #\C))
12)
((or (eq? c #\d)(eq? c #\D))
13)
((or (eq? c #\e)(eq? c #\E))
14)
((or (eq? c #\f)(eq? c #\F))
15)
(else (string->number (string c))))))
(set! colornumber (+ (* n 16) colornumber))))))
(define (little-endian->big-endian n)
(let ((str (string n))
(rets ""))
(do ((i (string-length str) (- i 1)))
((<= i 0)
(string->number rets))
(set! rets (string
(bitwise-and
(string->number (* (expt 2 i)(string-ref str i)))
(string->number rets)))))
))
(define (big-endian->littleendian n)
(let ((str (string n))
(rets ""))
(do ((i 0 (+ i 1)))
((>= i (string-length str))
(string->number rets))
(set! rets (string
(bitwise-and
(string->number (* (expt 2 i)(string-ref str i)))
(string->number rets)))))
))
(define (make-color-dictionary bpp)
(let ((dict (make-dictionary))
(pow (expt 2 bpp)))
(cond ((= pow 16) ;; 16 colors
(do ((i 0 (+ i 1)))
((< i pow)
(dictionary-add! dict i i)))
(dictionary-add! dict 'black 0)
;; ... FIXME fill in 4-bit colors
dict)
((= pow 256) ;; 256 colors
(dictionary-add! dict 'black 0)
;; ... FIXME fill in 8-bit colors
dict)
(else (display "color-dictionary : no or unsupported bit depth. Using CSS dictionary")
(dictionary-add! dict 'Black "000000")
(dictionary-add! dict 'Navy "000080")
(dictionary-add! dict 'DarkBlue "00008B")
(dictionary-add! dict 'MediumBlue "0000CD")
(dictionary-add! dict 'Blue "0000FF")
(dictionary-add! dict 'DarkGreen "006400")
(dictionary-add! dict 'Green "008000")
(dictionary-add! dict 'Teal "008080")
(dictionary-add! dict 'DarkCyan "008B8B")
(dictionary-add! dict 'DeepSkyBlue "00BFFF")
(dictionary-add! dict 'DarkTurquoise "00CED1")
(dictionary-add! dict 'MediumSpringGreen "00FA9A")
(dictionary-add! dict 'Lime "00FF00")
(dictionary-add! dict 'SpringGreen "00FF7F")
(dictionary-add! dict 'Aqua "00FFFF")
(dictionary-add! dict 'Cyan "00FFFF")
(dictionary-add! dict 'MidnightBlue "191970")
(dictionary-add! dict 'DodgerBlue "1E90FF")
(dictionary-add! dict 'LightSeaGreen "20B2AA")
(dictionary-add! dict 'ForestGreen "228B22")
(dictionary-add! dict 'SeaGreen "2E8B57")
(dictionary-add! dict 'DarkSlateGray "2F4F4F")
(dictionary-add! dict 'DarkSlateGrey "2F4F4F")
(dictionary-add! dict 'LimeGreen "32CD32")
(dictionary-add! dict 'MediumSeaGreen "3CB371")
(dictionary-add! dict 'Turquoise "40E0D0")
(dictionary-add! dict 'RoyalBlue "4169E1")
(dictionary-add! dict 'SteelBlue "4682B4")
(dictionary-add! dict 'DarkSlateBlue "483D8B")
(dictionary-add! dict 'MediumTurquoise "48D1CC")
(dictionary-add! dict 'Indigo "4B0082")
(dictionary-add! dict 'DarkOliveGreen "556B2F")
(dictionary-add! dict 'CadetBlue "5F9EA0")
(dictionary-add! dict 'CornflowerBlue "6495ED")
(dictionary-add! dict 'MediumAquaMarine "66CDAA")
(dictionary-add! dict 'DimGray "696969")
(dictionary-add! dict 'DimGrey "696969")
(dictionary-add! dict 'SlateBlue "6A5ACD")
(dictionary-add! dict 'OliveDrab "6B8E23")
(dictionary-add! dict 'SlateGray "708090")
(dictionary-add! dict 'SlateGrey "708090")
(dictionary-add! dict 'LightSlateGray "778899")
(dictionary-add! dict 'LightSlateGrey "778899")
(dictionary-add! dict 'MediumSlateBlue "7B68EE")
(dictionary-add! dict 'LawnGreen "7CFC00")
(dictionary-add! dict 'Chartreuse "7FFF00")
(dictionary-add! dict 'Aquamarine "7FFFD4")
(dictionary-add! dict 'Maroon "800000")
(dictionary-add! dict 'Purple "800080")
(dictionary-add! dict 'Olive "808000")
(dictionary-add! dict 'Gray "808080")
(dictionary-add! dict 'Grey "808080")
(dictionary-add! dict 'SkyBlue "87CEEB")
(dictionary-add! dict 'LightSkyBlue "87CEFA")
(dictionary-add! dict 'BlueViolet "8A2BE2")
(dictionary-add! dict 'DarkRed "8B0000")
(dictionary-add! dict 'DarkMagenta "8B008B")
(dictionary-add! dict 'SaddleBrown "8B4513")
(dictionary-add! dict 'DarkSeaGreen "8FBC8F")
(dictionary-add! dict 'LightGreen "90EE90")
(dictionary-add! dict 'MediumPurple "9370D8")
(dictionary-add! dict 'DarkViolet "9400D3")
(dictionary-add! dict 'PaleGreen "98FB98")
(dictionary-add! dict 'DarkOrchid "9932CC")
(dictionary-add! dict 'YellowGreen "9ACD32")
(dictionary-add! dict 'Sienna "A0522D")
(dictionary-add! dict 'Brown "A52A2A")
(dictionary-add! dict 'DarkGray "A9A9A9")
(dictionary-add! dict 'DarkGrey "A9A9A9")
(dictionary-add! dict 'LightBlue "ADD8E6")
(dictionary-add! dict 'GreenYellow "ADFF2F")
(dictionary-add! dict 'PaleTurquoise "AFEEEE")
(dictionary-add! dict 'LightSteelBlue "B0C4DE")
(dictionary-add! dict 'PowderBlue "B0E0E6")
(dictionary-add! dict 'FireBrick "B22222")
(dictionary-add! dict 'DarkGoldenRod "B8860B")
(dictionary-add! dict 'MediumOrchid "BA55D3")
(dictionary-add! dict 'RosyBrown "BC8F8F")
(dictionary-add! dict 'DarkKhaki "BDB76B")
(dictionary-add! dict 'Silver "C0C0C0")
(dictionary-add! dict 'MediumVioletRed "C71585")
(dictionary-add! dict 'IndianRed "CD5C5C")
(dictionary-add! dict 'Peru "CD853F")
(dictionary-add! dict 'Chocolate "D2691E")
(dictionary-add! dict 'Tan "D2B48C")
(dictionary-add! dict 'LightGray "D3D3D3")
(dictionary-add! dict 'LightGrey "D3D3D3")
(dictionary-add! dict 'PaleVioletRed "D87093")
(dictionary-add! dict 'Thistle "D8BFD8")
(dictionary-add! dict 'Orchid "DA70D6")
(dictionary-add! dict 'GoldenRod "DAA520")
(dictionary-add! dict 'Crimson "DC143C")
(dictionary-add! dict 'Gainsboro "DCDCDC")
(dictionary-add! dict 'Plum "DDA0DD")
(dictionary-add! dict 'BurlyWood "DEB887")
(dictionary-add! dict 'LightCyan "E0FFFF")
(dictionary-add! dict 'Lavender "E6E6FA")
(dictionary-add! dict 'DarkSalmon "E9967A")
(dictionary-add! dict 'Violet "EE82EE")
(dictionary-add! dict 'PaleGoldenRod "EEE8AA")
(dictionary-add! dict 'LightCoral "F08080")
(dictionary-add! dict 'Khaki "F0E68C")
(dictionary-add! dict 'AliceBlue "F0F8FF")
(dictionary-add! dict 'HoneyDew "F0FFF0")
(dictionary-add! dict 'Azure "F0FFFF")
(dictionary-add! dict 'SandyBrown "F4A460")
(dictionary-add! dict 'Wheat "F5DEB3")
(dictionary-add! dict 'Beige "F5F5DC")
(dictionary-add! dict 'WhiteSmoke "F5F5F5")
(dictionary-add! dict 'MintCream "F5FFFA")
(dictionary-add! dict 'GhostWhite "F8F8FF")
(dictionary-add! dict 'Salmon "FA8072")
(dictionary-add! dict 'AntiqueWhite "FAEBD7")
(dictionary-add! dict 'Linen "FAF0E6")
(dictionary-add! dict 'LightGoldenRodYellow "FAFAD2")
(dictionary-add! dict 'OldLace "FDF5E6")
(dictionary-add! dict 'Red "FF0000")
(dictionary-add! dict 'Fuchsia "FF00FF")
(dictionary-add! dict 'Magenta "FF00FF")
(dictionary-add! dict 'DeepPink "FF1493")
(dictionary-add! dict 'OrangeRed "FF4500")
(dictionary-add! dict 'Tomato "FF6347")
(dictionary-add! dict 'HotPink "FF69B4")
(dictionary-add! dict 'Coral "FF7F50")
(dictionary-add! dict 'Darkorange "FF8C00")
(dictionary-add! dict 'LightSalmon "FFA07A")
(dictionary-add! dict 'Orange "FFA500")
(dictionary-add! dict 'LightPink "FFB6C1")
(dictionary-add! dict 'Pink "FFC0CB")
(dictionary-add! dict 'Gold "FFD700")
(dictionary-add! dict 'PeachPuff "FFDAB9")
(dictionary-add! dict 'NavajoWhite "FFDEAD")
(dictionary-add! dict 'Moccasin "FFE4B5")
(dictionary-add! dict 'Bisque "FFE4C4")
(dictionary-add! dict 'MistyRose "FFE4E1")
(dictionary-add! dict 'BlanchedAlmond "FFEBCD")
(dictionary-add! dict 'PapayaWhip "FFEFD5")
(dictionary-add! dict 'LavenderBlush "FFF0F5")
(dictionary-add! dict 'SeaShell "FFF5EE")
(dictionary-add! dict 'Cornsilk "FFF8DC")
(dictionary-add! dict 'LemonChiffon "FFFACD")
(dictionary-add! dict 'FloralWhite "FFFAF0")
(dictionary-add! dict 'Snow "FFFAFA")
(dictionary-add! dict 'Yellow "FFFF00")
(dictionary-add! dict 'LightYellow "FFFFE0")
(dictionary-add! dict 'Ivory "FFFFF0")
(dictionary-add! dict 'White "FFFFFF")
))
))

50
scsh/scgame/scgameutil.scm Normal file
View File

@ -0,0 +1,50 @@
;;; scgameutil.scm - a scheme game library utility
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;; aspect-oriented features
(define (aspecterror)
(display "Message not understood."))
;; FIX : use scsh regexp instead of these following 2 functions
(define (string-cat s j)
(if (< j (string-length s))
(begin
(display j)
(string-append (string (string-ref s j)) (string-cat s (+ j 1)))
)
""))
(define (substring? needle haystack j)
;; (define (max? s1 s2 j)
(if (and (string? haystack)(string? needle))
(let ((hs (string-cat haystack j)))
((string>=? needle hs) hs))
#f))

45
scsh/scgame/scgamewidgets.scm Normal file
View File

@ -0,0 +1,45 @@
;;; scgame.scm - a scheme game library
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(load "scgameutil.scm")
(define (make-scgamewidget)
(lambda (msg)
(display "subclass responsability")))
(define (make-button)
(let ((*widget (make-scgamewidget))
(*image #f)) ;; pixel array
(define (set-image filename)
(((make-scimage2)'load-image) filename))
(lambda (msg)
(cond ((eq? 'set-image) set-image)
(else (aspecterror)(display "make-button"))
))))

82
scsh/scgame/scganadu.scm Normal file
View File

@ -0,0 +1,82 @@
;;; scganadu.scm - a Xanadu file system (until desktop publishing)
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(load "scgameutil.scm")
(load "scganaduutil.scm")
;; This code fabricates xanadu hypertext files to attach
;; to xanandu objects or use as metafiles
(define (make-scganadu)
(let ((record (delay #f)))
(define (add-file filename)
(let ((displayproc (write (((FILE-MAKER-unit (force record)) 'get-post-html)
(string-append "<filename>"
filename
"</filename>"))))
(with-output-to-file (string-append "." filename ".scganadu") displayproc)
)))
(define (attach-to-file! filename)
(let ((displayproc (write (((FILE-MAKER-unit (force record)) 'get-post-html)
(string-append "<filename>"
filename
"</filename>")))))
(with-output-to-file filename displayproc)
))
(define (dispatch msg)
(lambda (msg)
(cond ((eq? msg 'add-file)add-file)
((eq? msg 'attach-to-file!)attach-to-file!)
(else (aspecterror) (display "make-scganadu")))))
(define :scganadu-record
(make-record-type 'scganadu-record
'(FILE-MAKER make-scganadu)))
(define make-scganadu-record
(record-constructor :scganadu-record
'(FILE-MAKER make-scganadu)))
(define FILE-MAKER-unit (record-accessor :scganadu-record 'FILE-MAKER))
(define make-scganadu-unit (record-accessor :scganadu-record 'make-scganadu))
(define make-scganadu-record
(delay (make-copy-of-document))
(delay (make-cell dispatch)))
(set! record make-scganadu-record)
dispatch))
;; interface
(define scganadu (make-scganadu))
;; FIXME (define X (make-scganadu1))
(define (scganadu-add-file X filename) ((X 'add-file) filename))
(define (scganadu-attach-to-file! X filename) ((X 'attach-to-file! filename)))

67
scsh/scgame/scganaduutil.scm Normal file
View File

@ -0,0 +1,67 @@
;;; scganaduutil.scm - a scheme Xanadu utility
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(load "scgameutil.scm")
(define (make-copy-of-document)
(let ((*XMLOPENDATA (list "<scganadu>" "<audio>" "<image>"))
(*XMLCLOSEDATA (list "</scganadu>" "</audio>" "</image>"))
(*scganadutag! car)
(*audiotag! cadr)
(*imagetag! caadr)
)
(define (get-open-xml tag)
(tag *XMLOPENDATA))
(define (get-close-xml tag)
(tag *XMLCLOSEDATA))
(define (get-copyright)
"Copyright (C) unknown by SCGanadu."))
(define (get-post hypertext)
(get-post-html hypertext))
(define (get-post-html hypertext)
(string-append (get-open-xml scganadutag!) hypertext (get-open-xml scganadutag!))
(define (get-post-sound hypertext2)
(get-post-html (string (get-open-xml audiotag!) hypertext2 (get-close-xml audiotag!))))
(define (get-post-image hypertext3)
(get-post-html (string (get-open-xml imagetag!) hypertext3 (get-close-xml imagetag!))))
(lambda (msg)
(cond ((eq? msg 'get-copyright)
get-copyright)
((eq? msg 'get-post-sound)
get-post-sound)
((eq? msg 'get-post-image)
get-post-image)
((eq? msg 'get-post-scganadu)
get-post-scganadu)
((eq? msg 'get-post)
get-post)
(else (aspecterror) (display "make-copy-of-document")))))

22
scsh/scgame/test.xpm Normal file
View File

@ -0,0 +1,22 @@
/* XPM */
static char * test_xpm[] = {
"16 16 3 1",
" c gray77",
". c #000000000000",
"X c #861782078617",
" ",
" ",
"............... ",
". . . . . . . .X",
"...............X",
" X.XXXXXXX.XXXXX",
" .X .X ",
" .X .X ",
" .X .X ",
" .X .X ",
"............... ",
" . . . . . . . X",
"...............X",
" XXXXXXXXXXXXXXX",
" ",
" "};

1
scsh/tmail/AUTHORS Normal file
View File

@ -0,0 +1 @@
Copyright (C) 2011-2012 Johan Ceuppens

1
scsh/tmail/BLURB Normal file
View File

@ -0,0 +1 @@
tmail : a client-server mail system

12
scsh/tmail/NEWS Normal file
View File

@ -0,0 +1,12 @@
version 0.1
* working connection with a few commands (telnet localhost 1025 and
* type in MAIL\r\n or QUIT\r\n
* tdaemon.scm script which can be run in scsh to (run-daemon-child staterecord)
* "rc" alike tforks.scm, tserver.scm tclient.scm which contain tell-client and ask-server methods.
* tforks.scm contains record and daemon to be spawned by e.g. init or daemontools
* and uses fork-and-forget with 10 commands per session.
* old/ code directory
* daemon state record (port, host, etc.)
* telnetable daemon
* daemon state record
* dispatch object second executable file

10
scsh/tmail/README Normal file
View File

@ -0,0 +1,10 @@
- This is a mail daemon (lots of protocols)
Basically run scsh, ',open records sockets reduce' or sometimes
',open sockets records' and '(load "tdaemon.scm")'
telnet localhost 1025 and type in APOP\r\n or QUIT\r\n
for asking the server.
mailer daemon command history:
APOP retrieves full mailbox (FIXME)
STAT returns
LIST returns

8
scsh/tmail/packages.scm Normal file
View File

@ -0,0 +1,8 @@
(define-interface tmail-interface
(export
run-daemon-child))
(define-structure tmail
tmail-interface
(open scheme)
(files tdaemon trecords tclient tserver tforks tmailbox))

19
scsh/tmail/pkg-def.scm Normal file
View File

@ -0,0 +1,19 @@
(define-package "tmail"
(0 1)
((install-lib-version (1 3 0)))
(write-to-load-script
`((config)
(load ,(absolute-file-name "packages.scm"
(get-directory 'scheme #f)))))
(install-file "README" 'doc)
(install-file "NEWS" 'doc)
(install-string (COPYING) "COPYING" 'doc)
(install-file "packages.scm" 'scheme)
(install-file "tdaemon.scm" 'scheme)
(install-file "tforks.scm" 'scheme)
(install-file "tclient.scm" 'scheme)
(install-file "trecords.scm" 'scheme)
(install-file "tmailbox.scm" 'scheme)
(install-file "tmailbox-load.scm" 'scheme)
(install-file "util.scm" 'scheme)
(install-file "tserver.scm" 'scheme))

38
scsh/tmail/tclient.scm Normal file
View File

@ -0,0 +1,38 @@
;;; tclient.scm - a full-duplex connect-to-server
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(define (ask-server request port-number)
(call-with-values
(lambda ()
(socket-client (get-host-name) port-number))
(lambda (in out)
(display request out)
(close-output-port out)
(let ((answer (make-string-input-port in))) ; returns any server response into some string
(close-input-port in)
answer))))

59
scsh/tmail/tdaemon.scm Normal file
View File

@ -0,0 +1,59 @@
;;; tdaemon.scm - a scheme pop mail daemon (instantiated)
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;#!/home/erana/scheme/bin/scsh -ds \
;;!#
;;#!/home/erana/scheme/bin/scsh \
;;-lm tmail.scm -o mail-daemon -s
(load "trecords.scm")
(load "tclient.scm")
(load "tserver.scm")
(load "tforks.scm")
(display "FIXMES: mail-daemon structure needs carriage return statement")
(newline)
(define rc (make-daemon-record
(delay "localhost") ;; virtual host
(delay 1110)
(delay (open-socket (force (port rc))))
(delay "POP3 tmail server ready")
(delay "+OK ")
(delay "APOP ")
(delay "STAT")
(delay "LIST")
(delay "+OK POP3 server signing off")
(delay "Exceeded maximum transactions.")
(delay "500 Command not understood.")
(delay "HELO")
(delay "EHLO")))
(run-daemon-child rc)
(display "mail-daemon ends.")
(newline)

118
scsh/tmail/tforks.scm Normal file
View File

@ -0,0 +1,118 @@
;;; tforks.scm - a scheme daemon child process
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(load "trecords.scm")
(load "tserver.scm")
(load "tmailbox-load.scm")
;; You can spawn this
(define (run-daemon-child rec)
(display "Opening listening socket on host : ")
(display (force (hostname rec)))
(display " port unknown at this stage, default 1110 ")
(display " ...")
(newline)
(fork-and-forget
(let ((socket (force (sock rec))))
(begin
(
(lambda (request portnumber)
(call-with-values
(lambda ()
(socket-accept socket))
(lambda (in out)
(write request out)
(do ((i 0 (+ i 1)))
((> i 9)(display "Quitting mail daemon child.")(newline))
;; (iterate loop
;; ((count* i 0))
;; ()
;; (if (>= i 10)
;; (display "Quitting mail daemon child.")(newline)
(call-with-values ;; FIXME (let ((answer2 (read in)))
(lambda ()
(list (read in)(read in)))
(lambda (answer)
(let ((answer2 (car answer))
(answer3 (if (not (null? (cdr answer)))
(cadr answer)
'foo)))
(display "Asked something : ")(display (symbol->string answer2))(display " ")(display answer3)(newline)
(if (symbol? answer2)
(cond ((eq? 'APOP answer2)
(write mailbox-contents out)
;; FIXME write "" to user's mailbox file
;;(let ((out2 (open-output-file (string-append spooldirectory (getenv "USER")))))
;; (write out2 ""))
)
((eq? 'STAT answer2)
#t)
((eq? 'LIST answer2)
#t)
((eq? 'RETR answer2)
(let ((idx (string->number (symbol->string answer3))))
(if idx
(write (tmail-get-mail-with-index (getenv "USER") idx) out))))
;; for brokeness
((eq? 'USER answer2)
;;FIXME overflow
(let ((username (if (number? answer3)
(number->string answer3)
(symbol->string answer3))))
(setenv "USER" username)
(write "+OK user accepted - not implemented" out)))
((eq? 'PASS answer2)
(let ((pass (if (number? answer3)
(number->string answer3)
(symbol->string answer3))))
(write "+OK password accepted - not implemented" out)))
((eq? 'QUIT answer2)
(write (force (BYE rec)) out)
(close-input-port in)
(close-socket socket)
(close-output-port out)
(exit))
(else
(write (force (ERROR500 rec)) out))
))
))))
(write (force (SPAWNEND rec)) out)
(write (force (BYE rec)) out)
(close-input-port in)
(close-socket socket)
(close-output-port out)
(exit)
)))
(force (MOTD rec)) (port rec))
))))

53
scsh/tmail/tmailbox-load.scm Normal file
View File

@ -0,0 +1,53 @@
;;; tmailbox.scm - a scheme mailbox system for smtp
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(load "tmailbox.scm")
;; read in current user's mailbox
(define mailbox-contents (tmail-mailbox-contents (getenv "USER")))
;; get mail with index
(define (tmail-get-mail-with-index usernamestr idx)
(let ((mailboxcontents tmail-mailbox-contents))
(let ((s "")
(i 0))
;; FIXME make do*
(do ((j 0 (+ j 1)))
((string=? "From " s)
(set! i (+ i 1))
(if (= i (+ idx 1))
s)
)
(let ((c (string-ref mailboxcontents j)))
(if (string=? "From " s)
(set! s "From "))
(string-append s (string c)))))))

46
scsh/tmail/tmailbox.scm Normal file
View File

@ -0,0 +1,46 @@
;;; tmailbox.scm - a scheme mailbox system for smtp
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(define spooldirectory "/var/spool/mail/")
(define (tmail-read-in-mailbox username)
(let ((file (string-append spooldirectory username)))
(display file)
(let ((in (open-input-file file)))
(let ((mailboxcontents ""))
(do ((s (read-char in)(read-char in))
(i 0 (+ i 1)))
((eof-object? s) (if (= (string-length mailboxcontents) 0)
(display "empty mailbox"))
mailboxcontents)
(set! mailboxcontents (string-append mailboxcontents (string s)))
)))))
;; global
(define (tmail-mailbox-contents username) (tmail-read-in-mailbox username))

57
scsh/tmail/trecords.scm Normal file
View File

@ -0,0 +1,57 @@
;;; trecords.scm - records for tmail
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(define :daemon-record
(make-record-type 'daemon-record
'(hostname port sock MOTD ACK APOP STAT LIST BYE SPAWNEND ERROR500 HELO EHLO)))
(define make-daemon-record
(record-constructor :daemon-record
'(hostname port sock MOTD ACK APOP STAT LIST BYE SPAWNEND ERROR500 HELO EHLO)))
;; (define make-daemon-record-default
;; (record-constructor :daemon-record
;; '(hostname
;; 1025 #f
;; "Hello."
;; "OK."
;; "Bye."
;; "500 Command not understood."
;; "EHLO Server ready.")))
(define hostname (record-accessor :daemon-record 'hostname))
(define port (record-accessor :daemon-record 'port))
(define sock (record-accessor :daemon-record 'sock))
(define MOTD (record-accessor :daemon-record 'MOTD))
(define ACK (record-accessor :daemon-record 'ACK))
(define APOP (record-accessor :daemon-record 'APOP))
(define STAT (record-accessor :daemon-record 'STAT))
(define LIST (record-accessor :daemon-record 'LIST))
(define BYE (record-accessor :daemon-record 'BYE))
(define SPAWNEND (record-accessor :daemon-record 'SPAWNEND))
(define ERROR500 (record-accessor :daemon-record 'ERROR500))
(define HELO (record-accessor :daemon-record 'HELO))
(define EHLO (record-accessor :daemon-record 'EHLO))

43
scsh/tmail/tserver.scm Normal file
View File

@ -0,0 +1,43 @@
;;; tserver.scm - a full-duplex connect-to-client
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(define (tell-client request port-number sock)
(call-with-values
(lambda ()
(socket-accept sock))
(lambda (in out)
(display request out)
(display #\newline out)
;;(display #\return out)
;;FIXME(close-output-port out)
;;(let ((answer (make-string-input-port in))) ; returns any server response into some string
;;FIXME(close-input-port in)
;;answer)
)))

31
scsh/tmail/util.scm Normal file
View File

@ -0,0 +1,31 @@
;;; util.scm - tmail utilities
;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; 3. The name of the authors may not be used to endorse or promote products
;;; derived from this software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(define (aspecterror) (display " message not understood. "))