source: project/release/4/remote-mailbox/trunk/remote-mailbox-common.scm @ 34761

Last change on this file since 34761 was 34761, checked in by kon, 18 months ago

re-flow

File size: 2.1 KB
Line 
1;;;; remote-mailbox-common.scm
2;;;; Kon Lovett, Sep '09
3
4(module remote-mailbox-common
5
6(;export
7  ;;
8  mailbox-name? check-mailbox-name error-mailbox-name
9  tcp-port-no? check-tcp-port-no error-tcp-port-no
10  hostname? check-hostname error-hostname
11  ;;
12  default-remote-mailbox-tcp-port-no
13  default-remote-mailbox-hostname
14  ;DEPRECATED
15  default-remote-mailbox-tcp-port
16  tcp-port?
17  check-tcp-port
18  error-tcp-port
19)
20
21(import scheme chicken)
22
23(import
24  (only srfi-13 string-null?)
25  (only miscmacros define-parameter)
26  (only type-errors warning-argument-type)
27  (only type-checks define-check+error-type))
28(require-library srfi-13 miscmacros type-errors type-checks)
29
30;;;
31
32(define-constant DEFAULT-TCP-PORT-NO 63001)
33(define-constant DEFAULT-HOSTNAME "localhost")
34
35(define *environment-variable-tcp-port-no* (get-environment-variable "REMOTE-MAILBOX-TCP-PORT"))
36(define *environment-variable-hostname* (get-environment-variable "REMOTE-MAILBOX-HOSTNAME"))
37
38(define *tcp-port-no* (or *environment-variable-tcp-port-no* DEFAULT-TCP-PORT-NO))
39(define *hostname* (or *environment-variable-hostname* DEFAULT-HOSTNAME))
40
41;;;
42
43(define mailbox-name? symbol?)
44
45(define (tcp-port-no? obj)
46  (and
47    (fixnum? obj)
48    (and (fx< 0 obj) (fx< obj 65536))) )
49
50(define tcp-port? tcp-port-no?)
51
52(define (hostname? obj)
53  (and
54    (string? obj)
55    (not (string-null? obj))) )
56
57;;;
58
59(define-check+error-type mailbox-name)
60(define-check+error-type hostname)
61(define-check+error-type tcp-port)
62
63;;; Parameters
64
65(define-parameter default-remote-mailbox-tcp-port-no *tcp-port-no*
66        (lambda (x)
67                (cond
68                  ((tcp-port-no? x)  x )
69                  ((not x)        *tcp-port-no* )
70      (else
71        (warning-argument-type 'default-remote-mailbox-tcp-port-no x 'procedure)
72        (default-remote-mailbox-tcp-port-no) ) ) ) )
73
74(define default-remote-mailbox-tcp-port default-remote-mailbox-tcp-port-no)
75
76(define-parameter default-remote-mailbox-hostname *hostname*
77        (lambda (x)
78                (cond
79                  ((hostname? x)  x )
80                  ((not x)        *hostname* )
81      (else
82        (warning-argument-type 'default-remote-mailbox-hostname x 'procedure)
83        (default-remote-mailbox-hostname) ) ) ) )
84
85) ;module remote-mailbox-common
86
Note: See TracBrowser for help on using the repository browser.