source: project/release/4/dissector/command.scm @ 12396

Last change on this file since 12396 was 12286, checked in by felix winkelmann, 12 years ago

ported to chicken-4

File size: 5.8 KB
Line 
1;;;;;; Dissection commands
2
3;;; Copyright (C) 2004, Taylor Campbell
4;;; All rights reserved.
5;;; See the LICENCE file for details.
6
7;++ Come up with a better naming strategy for command-related things...
8
9(define (read-dissection-command port
10                                 k-eof k-failure k-blank k-success)
11  (let ((line (read-line port)))
12    (cond ((eof-object? line)
13           (k-eof))
14          ((= (string-length line) 0)
15           (k-blank))
16          (else
17           (let ((command-name.args
18                  (read-objects-from-string line 20)))
19             (if (and command-name.args
20                      (pair? command-name.args)
21                      (symbol? (car command-name.args))
22                      (list? (cdr command-name.args)))
23                 (k-success (car command-name.args)
24                            (cdr command-name.args))
25                 (k-failure line)))))))
26
27(define-record-type rtd/dissection-command
28  (make-dissection-command name aliases
29                           quick-help args-help long-help
30                           argc proc)
31  dissection-command?
32  (name dissection-command-name)
33  (aliases dissection-command-aliases)
34  (quick-help dissection-command-quick-help)
35  (args-help dissection-command-args-help)
36  (long-help dissection-command-long-help)
37  (argc dissection-command-argc)
38  (proc dissection-command-proc))
39
40(define *dissection-commands* '())
41(define (define-dissection-command name aliases
42                                   quick-help args-help long-help
43                                   argc proc)
44  (set! *dissection-commands*
45        (cons (make-dissection-command name aliases
46                                       quick-help args-help long-help
47                                       argc proc)
48              *dissection-commands*)))
49(define (dissection-command name)
50  (let loop ((commands *dissection-commands*))
51    (cond ((null? commands)
52           (error "No such dissection command" name))
53          ((or (eq? (dissection-command-name (car commands)) name)
54               (memq name (dissection-command-aliases (car commands))))
55           (car commands))
56          (else
57           (loop (cdr commands))))))
58
59(define (carefully-handle-dissection-command command-name dissection
60                                             arguments)
61  (with-exceptions-printed-to-port (dissection-outport dissection)
62    (lambda ()
63      (really-handle-dissection-command command-name dissection
64                                        arguments))))
65
66(define (really-handle-dissection-command command-name dissection
67                                          arguments)
68  (let* ((command (dissection-command command-name))
69         (argc (dissection-command-argc command))
70         (proc (dissection-command-proc command)))
71    (cond ((not argc) #t)
72          ((integer? argc)
73           (cond ((negative? argc)
74                  (if (not (length>=? arguments (- -1 argc)))
75                      (error "Too few arguments to command"
76                             `(expected at least ,(- -1 argc)))))
77                 ((not (length=? arguments argc))
78                  (error "Wrong number of arguments to command"
79                         `(expected ,argc)))))
80          (else
81           (if (not (any? (lambda (count) (length=? arguments count))
82                          argc))
83               (error "Wrong number of arguments to command"
84                      `(expected any of ,argc)))))
85    (apply proc dissection arguments)))
86
87
88
89;;; --------------------
90;;; Displaying command help
91
92;++ The help messages really ought to be fit into your terminal width.
93
94(define (display-help-synopsis port)
95  (display "This is the interactive Chicken dissector." port)
96  (newline port)
97  (newline port)
98  (display "Supported dissector commands:" port)
99  (newline port)
100  (for-each (lambda (command)
101              (display "   " port)
102              (write (dissection-command-name command) port)
103              (let ((aliases (dissection-command-aliases command)))
104                (cond ((not (null? aliases))
105                       (display " " port)
106                       (write aliases port))))
107              (display " - " port)
108              (display (dissection-command-quick-help command) port)
109              (newline port))
110            (dissector-sort *dissection-commands*
111              (lambda (cmd-a cmd-b)
112                (string<? (symbol->string
113                           (dissection-command-name cmd-a))
114                          (symbol->string
115                           (dissection-command-name cmd-b))))))
116  (newline port)
117  (display "For help on an individual command, use: ? <command>" port)
118  (newline port)
119  (flush-output port))
120
121(define (display-command-help command port)
122  (display "Dissector command: ")
123  (display (dissection-command-name command) port)
124  (cond ((dissection-command-args-help command)
125         => (lambda (args-help)
126              (display " " port)
127              (display args-help port))))
128  (let ((aliases (dissection-command-aliases command)))
129    (cond ((not (null? aliases))
130           (newline port)
131           (display "      " port)
132           (write (cons 'aliases: aliases) port))))
133  (newline port)
134  (for-each (lambda (line)
135              (display "   " port)
136              (display line  port)
137              (newline port))
138            (cond ((dissection-command-long-help command))
139                  (else
140                   (list (dissection-command-quick-help command)))))
141  (flush-output port))
142
143(define-dissection-command 'help '(?)
144  "Print help for commands."
145  "[<command>]"
146  '("If COMMAND is absent, prints out a brief help synopsis for every"
147    "supported command; otherwise prints out help for COMMAND.")
148  '(0 1)
149  (case-lambda
150    ((dissector)
151     (display-help-synopsis (dissection-outport dissector)))
152    ((dissector command)
153     (display-command-help (dissection-command command)
154                           (dissection-outport dissector)))))
155
Note: See TracBrowser for help on using the repository browser.