1#!/usr/bin/env sh
2exec @GUILE@ -s "$0" "$@"
3!#
4
5;;; Lepton EDA attribute editor
6;;; Copyright (C) 2003-2010 Stuart D. Brorson.
7;;; Copyright (C) 2005-2016 gEDA Contributors
8;;; Copyright (C) 2017-2021 Lepton EDA Contributors
9;;;
10;;; This program is free software; you can redistribute it and/or modify
11;;; it under the terms of the GNU General Public License as published by
12;;; the Free Software Foundation; either version 2 of the License, or
13;;; (at your option) any later version.
14;;;
15;;; This program is distributed in the hope that it will be useful,
16;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18;;; GNU General Public License for more details.
19;;;
20;;; You should have received a copy of the GNU General Public License
21;;; along with this program; if not, write to the Free Software
22;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
23
24(eval-when (expand load eval)
25  (unless (getenv "LIBLEPTON")
26    (add-to-load-path "@LEPTON_SCHEME_MODULE_DIRECTORY@")
27    (set! %load-compiled-path (cons "@ccachedir@" %load-compiled-path))))
28
29(use-modules (ice-9 getopt-long)
30             (ice-9 receive)
31             (srfi srfi-1)
32             (system foreign)
33             (lepton ffi)
34             (lepton ffi lib))
35
36;;; Initialize liblepton library.
37(liblepton_init)
38(unless (getenv "LEPTON_INHIBIT_RC_FILES")
39  (register-data-dirs))
40(edascm_init)
41
42(define libleptonattrib (dynamic-link %libleptonattrib))
43
44(define gtk-init
45  (pointer->procedure
46   void
47   (dynamic-func "gtk_init" libgtk)
48   (list '* '*)))
49
50(define gtk-main
51  (pointer->procedure
52   void
53   (dynamic-func "gtk_main" libgtk)
54   '()))
55
56(define set-verbose-mode!
57  (pointer->procedure
58   void
59   (dynamic-func "set_verbose_mode" libleptonattrib)
60   '()))
61
62(define fileselect-open
63  (pointer->procedure
64   '*
65   (dynamic-func "x_fileselect_open" libleptonattrib)
66   '()))
67
68(define lepton-attrib-window
69  (pointer->procedure
70   void
71   (dynamic-func "lepton_attrib_window" libleptonattrib)
72   '()))
73
74;;; Localization.
75(define %textdomain "libleptonattrib")
76(bindtextdomain %textdomain "@localedir@")
77(textdomain %textdomain)
78(bind-textdomain-codeset %textdomain "UTF-8")
79(setlocale LC_ALL "")
80(setlocale LC_NUMERIC "C")
81
82(define (G_ msg) (gettext msg %textdomain))
83
84(primitive-eval '(use-modules (lepton core toplevel)
85                              (lepton file-system)
86                              (lepton log)
87                              (lepton page)
88                              (lepton rc)
89                              (lepton version)))
90
91(define (usage)
92  (format #t
93          (G_ "Usage: ~A [OPTIONS] FILE ...
94
95lepton-attrib: Lepton EDA attribute editor.
96Presents schematic attributes in easy-to-edit spreadsheet format.
97
98Options:
99  -v, --verbose          Verbose mode on
100  -V, --version          Show version information
101  -h, --help             This help menu
102
103Report bugs at ~S
104Lepton EDA homepage: ~S
105")
106          (basename (car (program-arguments)))
107          (lepton-version-ref 'bugs)
108          (lepton-version-ref 'url))
109
110  (primitive-exit 0))
111
112
113(define (report-unreadable filename)
114  (format (current-error-port)
115          "Could not open file ~S.\n"
116          filename))
117
118(define (gslist->list gslist)
119  (let loop ((gsls gslist)
120             (ls '()))
121    (if (null-pointer? gsls)
122        ls
123        (let* ((elem (parse-c-struct gsls (list '* '*)))
124               (str (pointer->string (first elem)))
125               (gsls (second elem)))
126          (loop gsls (cons str ls))))))
127
128
129(define (process-gafrc* name)
130  (process-gafrc "lepton-attrib" name))
131
132
133;;; Init logging.
134(init-log "attrib")
135(display-lepton-version #:print-name #t #:log #t)
136
137
138(let* ((option-spec '((help (single-char #\h))
139                      (verbose (single-char #\v))
140                      (version (single-char #\V))))
141
142       (options (getopt-long (program-arguments) option-spec))
143       (help (option-ref options 'help #f))
144       (version (option-ref options 'version #f))
145       (files (option-ref options '() '()))
146       (verbose? (option-ref options 'verbose #f)))
147
148  (when help (usage))
149  ;; Output version to stdout and exit, if requested.
150  (when version
151    (display-lepton-version #:print-name #t #:copyright #t)
152    (primitive-exit 0))
153  (when verbose? (set-verbose-mode!))
154
155  (receive (readable-files unreadable-files)
156      (partition file-readable? files)
157    (if (null? unreadable-files)
158        ;; Main procedure.
159        (begin
160          ;; Initialize GTK.
161          (gtk-init %null-pointer %null-pointer)
162          (let ((files (if (null? readable-files)
163                           ;; No files specified on the command
164                           ;; line, pop up the File open dialog.
165                           (gslist->list (fileselect-open))
166                           readable-files)))
167            (if (null? files)
168                (primitive-exit 0)
169                (%with-toplevel (%make-toplevel)
170                 (lambda ()
171                   (for-each process-gafrc* files)
172                   ;; Open all files.
173                   (for-each file->page files)
174                   ;; Run attribute editor.
175                   (lepton-attrib-window)
176                   ;; Run main GTK loop.
177                   (gtk-main)
178                   (primitive-exit 0))))))
179        ;; There are non-existing or unreadable files.  Report and
180        ;; exit.
181        (begin
182          (for-each report-unreadable unreadable-files)
183          (primitive-exit 1)))))
184