blob: 0ee4adcf88e15104b6135fe78eed6f130bc1f1a6 (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
(define-module (loadavg ui)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-1)
#:use-module (ssh session)
#:use-module (ssh auth)
#:use-module (ssh popen)
#:use-module ((guix ui) #:select (colorize-string))
#:autoload (ice-9 ftw) (scandir)
#:use-module ((guix ui) #:select (G_ leave))
#:use-module (loadavg config)
#:export (loadavg-main))
(define (show-bug-report-information)
;; TRANSLATORS: The placeholder indicates the bug-reporting address for this
;; package. Please add another line saying "Report translation bugs to
;; ...\n" with the address for translation bugs (typically your translation
;; team's web or email address).
(format #t (G_ "
Report bugs to: ~a.") %loadavg-bug-report-address)
(format #t (G_ "
~a home page: <~a>") %loadavg-package-name %loadavg-home-page-url)
(newline))
(define (show-loadavg-usage)
(format (current-error-port)
"Try `loadavg --help' for more information.~%")
(exit 1))
(define (command-files)
"Return the list of source files that define LOADAVG sub-commands."
(define directory
(and=> (search-path %load-path "loadavg.scm")
(compose (cut string-append <> "/loadavg/scripts")
dirname)))
(define dot-scm?
(cut string-suffix? ".scm" <>))
(if directory
(scandir directory dot-scm?)
'()))
(define (commands)
"Return the list of LOADAVG command names."
(map (compose (cut string-drop-right <> 4)
basename)
(command-files)))
(define (show-loadavg-help)
(format
#t
"Usage: loadavg COMMAND ARGS...\nRun COMMAND with ARGS.\n")
(newline)
(format
#t
"COMMAND must be one of the sub-commands listed below:\n")
(newline)
(format
#t
"~{ ~a~%~}"
(sort (commands) string<?))
(show-bug-report-information))
(define program-name
;; Name of the command-line program currently executing, or #f.
(make-parameter #f))
(define (run-loadavg-command command . args)
"Run COMMAND with the given ARGS. Report an error when COMMAND is not
found."
(define module
(catch 'misc-error
(lambda ()
(resolve-interface `(loadavg scripts ,command)))
(lambda -
(format (current-error-port)
"loadavg: ~a: command not found~%" command)
(show-loadavg-usage))))
(let ((command-main (module-ref module
(symbol-append 'loadavg- command))))
(parameterize ((program-name command))
;; Disable canonicalization so we don't don't stat unreasonably.
(with-fluids ((%file-port-name-canonicalization #f))
(dynamic-wind
(const #f)
(lambda ()
(apply command-main args))
(lambda ()
;; Abuse 'exit-hook' (which is normally meant to be used by the
;; REPL) to run things like profiling hooks upon completion.
(run-hook exit-hook)))))))
(define (run-loadavg . args)
"Run the 'loadavg' command defined by command line ARGS."
;; The default %LOAD-EXTENSIONS includes the empty string, which doubles the
;; number of 'stat' calls per entry in %LOAD-PATH. Shamelessly remove it.
(set! %load-extensions '(".scm"))
(match args
(()
(format (current-error-port) "loadavg: missing command name~%")
(show-loadavg-usage))
((or ("-h") ("--help"))
(show-loadavg-help))
((command args ...)
(apply run-loadavg-command (string->symbol command) args))))
(define (loadavg-main arg0 . args)
(apply run-loadavg args))
;;;
;;; main
;;;
(define* (main #:optional (args (command-line)))
(exit (apply loadavg-main args)))
|
