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