• R/O
  • SSH

cl-sack: Commit

CL-Sack is a Common Lisp library for making and manipulating Sack files.


Commit MetaInfo

Revisionc9f6ddba5fabb6561842c1ba256af948ff8557b9 (tree)
Time2019-02-09 08:45:39
AuthorAlexa Jones-Gonzales <alexa@part...>
CommiterAlexa Jones-Gonzales

Log Message

Migrating GUI to McClim

Change Summary

Incremental Difference

diff -r ab684d1d1152 -r c9f6ddba5fab gsacked-src/globals.lisp
--- a/gsacked-src/globals.lisp Wed Feb 06 23:25:44 2019 -0700
+++ b/gsacked-src/globals.lisp Fri Feb 08 16:45:39 2019 -0700
@@ -13,25 +13,16 @@
1313 ;;;;
1414 ;;;; You should have received a copy of the GNU General Public License
1515 ;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
16-
1716 (in-package :p36.gsacked)
1817
19-(defparameter *sacked-name* "GSacked")
20-(defparameter *sacked-long-name* "GSacked")
21-(defparameter *sacked-version* "1.0")
22-
23-(defparameter *log-output* *standard-output*)
18+(defparameter *program-name* (slot-value (asdf:find-system :gsacked) 'asdf::name))
19+(defparameter *program-long-name* (asdf:system-long-name (asdf:find-system :gsacked)))
20+(defparameter *program-version* (slot-value (asdf:find-system :gsacked) 'asdf::version))
2421
25-(defparameter *sacked-padding* 4)
26-(defparameter *application-frame* nil)
27-(defparameter *status-label* nil)
22+(defparameter *main-window-min-width* 1366)
23+(defparameter *main-window-min-height* 900)
2824
29-(defparameter *tree-view* nil)
30-(defparameter *tree-store* nil)
25+(defparameter *main-window* nil)
3126
32-(defparameter *tree-store-type-col* 0)
33-(defparameter *tree-store-name-col* 1)
34-(defparameter *tree-store-size-col* 2)
35-
36-(defparameter *need-saving* nil)
37-(defparameter *loaded-sack* nil)
27+(declaim (type (or argparser:parser null) *args*))
28+(defparameter *args* nil)
diff -r ab684d1d1152 -r c9f6ddba5fab gsacked-src/gui-main-window.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gsacked-src/gui-main-window.lisp Fri Feb 08 16:45:39 2019 -0700
@@ -0,0 +1,123 @@
1+;;;; GSacked - A graphical tool to create and edit Sack files
2+;;;; Copyright (C) 2016-2019 Alexa Jones-Gonzales <alexa@partition36.com>
3+;;;;
4+;;;; This program is free software: you can redistribute it and/or modify
5+;;;; it under the terms of the GNU General Public License as published by
6+;;;; the Free Software Foundation, either version 3 of the License, or
7+;;;; (at your option) any later version.
8+;;;;
9+;;;; This program is distributed in the hope that it will be useful,
10+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12+;;;; GNU General Public License for more details.
13+;;;;
14+;;;; You should have received a copy of the GNU General Public License
15+;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
16+(in-package :p36.gsacked)
17+
18+(define-command-table menu/main-window/file
19+ :menu (("New" :command com/new)
20+ ("Open" :command com/open)
21+ (nil :divider "|")
22+ ("Save" :command com/save)
23+ ("Save As..." :command com/save-as)
24+ (nil :divider "|")
25+ ("Quit" :command com/quit)))
26+
27+(define-command-table menu/main-window/help
28+ :menu (("About" :command com/about)))
29+
30+(define-command-table menu/main-window
31+ :menu
32+ (("File" :menu menu/main-window/file)
33+ ("Help" :menu menu/main-window/help)))
34+
35+(define-application-frame main-window ()
36+ ((loaded-sack
37+ :initform nil
38+ :type (or null cl-sack:sack-file)
39+ :accessor loaded-sack)
40+
41+ (needs-saving-p
42+ :initform t
43+ :type boolean
44+ :accessor needs-saving-p))
45+
46+ (:panes
47+ (entry-list clim-stream-pane
48+ :display-time t
49+ :scroll-bars t)
50+ (data-view clim-stream-pane)
51+ (int :interactor :height 200 :width *main-window-min-width*)
52+ (pdoc :pointer-documentation))
53+
54+ (:menu-bar menu/main-window)
55+
56+ (:layouts
57+ (default
58+ (vertically (:min-width *main-window-min-width* :min-height *main-window-min-height*)
59+ (+fill+
60+ (horizontally ()
61+ (1/4 (labelling (:label "Entries")
62+ (scrolling ()
63+ entry-list)))
64+ (+fill+ (labelling (:label "Data View")
65+ (scrolling ()
66+ data-view)))))
67+ int
68+ pdoc))))
69+
70+
71+(define-main-window-command (com/about :name (format nil "About ~a" *program-long-name*))
72+ ()
73+ (format (frame-standard-output *main-window*) "Not yet implemented~%"))
74+
75+(define-main-window-command (com/new :name "New Sack" :keystroke (#\n :control))
76+ ()
77+ (format (frame-standard-output *main-window*) "Not yet implemented~%"))
78+
79+(define-main-window-command (com/open :name "Open Sack" :keystroke (#\o :control))
80+ ((really-open? 'boolean :gesture :select
81+ :prompt "You have unsaved changes! Do you really want to open a new file?"
82+ :when (needs-saving-p *main-window*)))
83+
84+ (unless really-open?
85+ (return-from com/open))
86+
87+ (let ((filename "")
88+ (out (frame-standard-output *main-window*)))
89+ (accepting-values ()
90+ (setf filename (accept 'pathname :prompt "Path to Sack file")))
91+
92+ (cond
93+ ((not filename)
94+ (format out "Error: No filename specified~%~%"))
95+
96+ ((not (probe-file filename))
97+ (format out "Error: File does not exist~%~%"))
98+
99+ (t
100+ (handler-bind
101+ ((cl-sack:sack-error
102+ #'(lambda (err)
103+ (format out "Error loading sack file: ~a~%~%" (cl-sack:error-message err))
104+ (invoke-restart 'abort))))
105+
106+ (setf (loaded-sack *main-window*) (cl-sack:load-sack filename))
107+ (format out "Sack file loaded, ~a entries found.~%" (cl-sack:num-entries (loaded-sack *main-window*)))
108+ (setf (needs-saving-p *main-window*) nil))))))
109+
110+(define-main-window-command (com/save :name "Save" :keystroke (#\s :control))
111+ ()
112+ (format (frame-standard-output *main-window*) "Not yet implemented~%"))
113+
114+(define-main-window-command (com/save-as :name "Save As...")
115+ ()
116+ (format (frame-standard-output *main-window*) "Not yet implemented~%"))
117+
118+(define-main-window-command (com/quit :name "Quit" :keystroke (#\q :control))
119+ ((really-quit? 'boolean
120+ :gesture :select
121+ :prompt "Are you sure you want to quit?"))
122+ (when really-quit?
123+ (frame-exit *main-window*)))
diff -r ab684d1d1152 -r c9f6ddba5fab gsacked-src/main-window-menu-events.lisp
--- a/gsacked-src/main-window-menu-events.lisp Wed Feb 06 23:25:44 2019 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,113 +0,0 @@
1-;;;; GSacked - A graphical tool to create and edit Sack files
2-;;;; Copyright (C) 2016 Alexa Jones-Gonzales <alexa@partition36.com>
3-;;;;
4-;;;; This program is free software: you can redistribute it and/or modify
5-;;;; it under the terms of the GNU General Public License as published by
6-;;;; the Free Software Foundation, either version 3 of the License, or
7-;;;; (at your option) any later version.
8-;;;;
9-;;;; This program is distributed in the hope that it will be useful,
10-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12-;;;; GNU General Public License for more details.
13-;;;;
14-;;;; You should have received a copy of the GNU General Public License
15-;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
16-
17-(in-package :p36.gsacked)
18-
19-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
20-;;;
21-;;; Events For The Main Window's Menu
22-;;;
23-
24-(defun file/quit=>activate (obj)
25- (declare (ignore obj))
26-
27- (when (show-yes-no "Are you sure you want to quit?")
28- (gtk:gtk-widget-destroy *application-frame*)
29- (do-normal-quit)))
30-
31-(defun file/new=>activate (obj)
32- (declare (ignore obj))
33-
34- (when (and *need-saving*
35- (not (show-yes-no "The current Sack is not saved. Really start a new one?")))
36- (return-from file/new=>activate))
37-
38- ;; Clear the memory of the current Sack
39- (log-message "Unloading old Sack file")
40- (setf *loaded-sack* nil)
41- (sb-ext:gc :full t)
42-
43- ;; Load the new Sack
44- (log-message "Starting new Sack")
45- (setf *loaded-sack* (cl-sack:make-sack-file))
46-
47- (log-message "Updating main window")
48- (update-main-window))
49-
50-(defun file/save=>activate (obj)
51- (declare (ignore obj))
52-
53- t)
54-
55-(defun file/save-as=>activate (obj)
56- (declare (ignore obj))
57-
58- t)
59-
60-(defun file/close=>activate (obj)
61- (declare (ignore obj))
62-
63- t)
64-
65-(defun file/open=>activate (obj)
66- (declare (ignore obj))
67-
68- (when (and *need-saving*
69- (not (show-yes-no "The current Sack is not saved. Really open another one?")))
70- (return-from file/open=>activate))
71-
72- (let ((dlg (gtk:gtk-file-chooser-dialog-new
73- (format nil "~a: Open Sack" *sacked-name*) *application-frame*
74- :open "gtk-cancel" :cancel "gtk-open" :accept)))
75-
76- (handler-case
77- (when (equal (gtk:gtk-dialog-run dlg) :accept)
78- ;; Clear the memory of the current Sack
79- (log-message "Unloading old Sack file")
80- (setf *loaded-sack* nil)
81- (sb-ext:gc :full t)
82-
83- ;; Load the new Sack
84- (log-message "Loading Sack: ~a" (gtk:gtk-file-chooser-get-filename dlg))
85- (setf *loaded-sack*
86- (cl-sack:load-sack-file-frontmatter (gtk:gtk-file-chooser-get-filename dlg)))
87-
88- (log-message "Sack file is loaded, updating main window")
89- (update-main-window))
90-
91- (cl-sack:sack-load-error (err)
92- (show-error (format nil "Could not load the specified file.~%~%~a" err))))
93-
94- (gtk:gtk-widget-destroy dlg)))
95-
96-(defun help/about=>activate (obj)
97- (declare (ignore obj))
98-
99- (let ((dlg (make-instance 'gtk:gtk-about-dialog
100- :parent *application-frame*
101- :wrap-license t
102- :website "http://alexa.partition36.com/programming/sack-tools"
103- :version *sacked-version*
104- :program-name *sacked-long-name*
105- :authors '("Alexa Jones-Gonzales <alexa@partition36.com>")
106- :comments "A graphical tool to create and edit Sack files"
107- :copyright "Copyright (C) 2016-2017 Alexa Jones-Gonzales"
108- :license "GPLv3+
109-
110-This is free software. You may redistribute copies of it under the terms of the GNU General Public License <http://www.gnu.org/licenses/gpl.html>. There is NO WARRANTY, to the extent permitted by law.")))
111-
112- (gtk:gtk-dialog-run dlg)
113- (gtk:gtk-widget-destroy dlg)))
diff -r ab684d1d1152 -r c9f6ddba5fab gsacked-src/main.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gsacked-src/main.lisp Fri Feb 08 16:45:39 2019 -0700
@@ -0,0 +1,65 @@
1+;;;; GSacked - A graphical tool to create and edit Sack files
2+;;;; Copyright (C) 2016-2019 Alexa Jones-Gonzales <alexa@partition36.com>
3+;;;;
4+;;;; This program is free software: you can redistribute it and/or modify
5+;;;; it under the terms of the GNU General Public License as published by
6+;;;; the Free Software Foundation, either version 3 of the License, or
7+;;;; (at your option) any later version.
8+;;;;
9+;;;; This program is distributed in the hope that it will be useful,
10+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12+;;;; GNU General Public License for more details.
13+;;;;
14+;;;; You should have received a copy of the GNU General Public License
15+;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
16+(in-package :p36.gsacked)
17+
18+(defun setup-command-line ()
19+ (setf *args* (argparser:make-parser :program-name (string-downcase *program-name*)
20+ :program-formal-name *program-long-name*
21+ :program-version *program-version*))
22+
23+ (argparser:defargument *args* "font-size" :type :string
24+ :documentation "Use the given font size (in points)")
25+
26+ (argparser:defargument *args* "verbose" :short-name #\v
27+ :type :multi-flag
28+ :documentation "Enable non-debugging informational messages. This
29+ can be specified multiple times for more verbose output.")
30+
31+ (argparser:defargument *args* "debug" :short-name #\g
32+ :type :multi-flag
33+ :documentation "Enable debug logging. This can be specified
34+ multiple times for more verbose output."))
35+
36+(defun ui/main ()
37+ (handler-case
38+ (when (argparser:get-arg-value *args* "font-size")
39+ (setf clim-clx::*default-text-style*
40+ (clim-clx::make-text-style
41+ :sans-serif :roman
42+ (parse-integer (argparser:get-arg-value *args* "font-size")))))
43+ (parse-error ()
44+ (die-now "Invalid parameter passed to --font-size")))
45+
46+ (setf *main-window* (make-application-frame 'main-window))
47+ (run-frame-top-level *main-window*))
48+
49+(defun main (&rest fake-argv)
50+ (setf p36-log:*default-header* *program-name*)
51+ (setup-command-line)
52+
53+ (argparser:parse-arguments *args* (if (> (length fake-argv) 0)
54+ fake-argv
55+ (argparser:get-implementation-args (> (length fake-argv) 0)))
56+ (find-package :swank))
57+
58+ (p36-log:flog () "Starting AtEdit...~%")
59+
60+ (setf p36-log:*log-level* (or (argparser:get-arg-value *args* "verbose") 255))
61+ (setf p36-log:*debug-level* (or (argparser:get-arg-value *args* "debug") 255))
62+ (setf p36-log:*force-output* (< p36-log:*debug-level* 255))
63+
64+ (p36-log:flog () "Starting GUI...~%")
65+ (ui/main))
diff -r ab684d1d1152 -r c9f6ddba5fab gsacked-src/message-handler.lisp
--- a/gsacked-src/message-handler.lisp Wed Feb 06 23:25:44 2019 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,54 +0,0 @@
1-;;;; GSacked - A graphical tool to create and edit Sack files
2-;;;; Copyright (C) 2016 Alexa Jones-Gonzales <alexa@partition36.com>
3-;;;;
4-;;;; This program is free software: you can redistribute it and/or modify
5-;;;; it under the terms of the GNU General Public License as published by
6-;;;; the Free Software Foundation, either version 3 of the License, or
7-;;;; (at your option) any later version.
8-;;;;
9-;;;; This program is distributed in the hope that it will be useful,
10-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12-;;;; GNU General Public License for more details.
13-;;;;
14-;;;; You should have received a copy of the GNU General Public License
15-;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
16-
17-(in-package :p36.gsacked)
18-
19-(defun show-error (message &key (parent *application-frame*) title)
20- (declare (simple-string message)
21- (type (or simple-string null) title)
22- (type (or gtk:gtk-window null) parent))
23-
24- (let* ((dlg (gtk:gtk-message-dialog-new parent '(:modal :destroy-with-parent)
25- :error :ok message)))
26-
27- (setf (gtk:gtk-window-title dlg)
28- (concatenate 'string
29- *sacked-long-name*
30- (when title
31- (concatenate 'string " - " title))))
32-
33- (gtk:gtk-dialog-run dlg)
34- (gtk:gtk-widget-destroy dlg)))
35-
36-
37-(defun show-yes-no (message &key (parent *application-frame*) title)
38- (declare (string message)
39- (type (or string null) title)
40- (type (or gtk:gtk-window null) parent))
41-
42- (let* ((dlg (make-instance 'gtk:gtk-message-dialog
43- :text message
44- :title (concatenate 'string
45- *sacked-long-name*
46- (when title
47- (concatenate 'string " - " title)))
48- :message-type :question
49- :buttons :yes-no
50- :parent parent))
51- (ret (gtk:gtk-dialog-run dlg)))
52-
53- (gtk:gtk-widget-destroy dlg)
54- (equal ret :yes)))
diff -r ab684d1d1152 -r c9f6ddba5fab gsacked-src/package.lisp
--- a/gsacked-src/package.lisp Wed Feb 06 23:25:44 2019 -0700
+++ b/gsacked-src/package.lisp Fri Feb 08 16:45:39 2019 -0700
@@ -16,5 +16,5 @@
1616
1717 (defpackage :p36.gsacked
1818 (:nicknames :gsacked)
19- (:use :common-lisp)
20- (:export :main))
19+ (:use :clim :clim-lisp)
20+ (:export #:main))
diff -r ab684d1d1152 -r c9f6ddba5fab gsacked-src/sacked-gui.lisp
--- a/gsacked-src/sacked-gui.lisp Wed Feb 06 23:25:44 2019 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,276 +0,0 @@
1-;;;; GSacked - A graphical tool to create and edit Sack files
2-;;;; Copyright (C) 2016 Alexa Jones-Gonzales <alexa@partition36.com>
3-;;;;
4-;;;; This program is free software: you can redistribute it and/or modify
5-;;;; it under the terms of the GNU General Public License as published by
6-;;;; the Free Software Foundation, either version 3 of the License, or
7-;;;; (at your option) any later version.
8-;;;;
9-;;;; This program is distributed in the hope that it will be useful,
10-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12-;;;; GNU General Public License for more details.
13-;;;;
14-;;;; You should have received a copy of the GNU General Public License
15-;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
16-
17-;;;
18-;;; Contains the main window and the initialization routines
19-;;;
20-
21-(in-package :p36.gsacked)
22-
23-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24-;;;
25-;;; Events
26-;;;
27-
28-(defun main-window=>delete-event (window event)
29- (declare (ignore event))
30-
31- (cond
32- ((show-yes-no "Are you sure you want to quit?" :parent window)
33- (do-normal-quit)
34- nil)
35-
36- (t t)))
37-
38-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
39-;;;
40-;;; Widget Handling
41-;;;
42-
43-(defun update-main-window ()
44- (let ((entry nil) (iter nil)
45- (region nil))
46- (declare (type (or cl-sack:sack-entry null) entry))
47-
48- (log-message-no-newline "Updating tree view with ~:d entries "
49- (cl-sack:num-entries *loaded-sack*))
50-
51- ;; Update status label
52- (setf (gtk:gtk-label-label *status-label*)
53- (format nil "Entries: ~a" (cl-sack:num-entries *loaded-sack*)))
54-
55- ;; Clear the model
56- (gtk:gtk-list-store-clear *tree-store*)
57-
58- ;; Pause drawing of the tree view for now
59- (setf region (gdk:gdk-window-get-visible-region (gtk:gtk-widget-window *tree-view*)))
60- (setf (gtk:gtk-widget-double-buffered *tree-view*) nil)
61- (gdk:gdk-window-begin-paint-region (gtk:gtk-widget-window *tree-view*) region)
62-
63- ;; Fill the model with the entries
64- (dotimes (i (cl-sack:num-entries *loaded-sack*))
65- (format *log-output* ".")
66- (finish-output *log-output*)
67-
68- (setf entry (cl-sack:get-entry *loaded-sack* i))
69- (setf iter (gtk:gtk-list-store-append *tree-store*))
70-
71- (gtk:gtk-list-store-set *tree-store* iter
72- (cl-sack:name
73- (cl-sack:get-entry-type-by-num
74- *loaded-sack* (cl-sack:get-entry-type entry)))
75- (cl-sack:name entry)
76- (format nil "~:d" (cl-sack:data-length entry))))
77-
78- ;; Reenable drawing of the tree view
79- (gdk:gdk-window-end-paint (gtk:gtk-widget-window *tree-view*))
80- (setf (gtk:gtk-widget-double-buffered *tree-view*) t)
81- (cairo:cairo-region-destroy region)
82-
83- (log-message "~%Main window has been updated")))
84-
85-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
86-;;;
87-;;; Main Window Setup
88-;;;
89-
90-(declaim (ftype (function (t) t)
91- file/new=>activate file/open=>activate
92- file/save=>activate file/save-as=>activate
93- file/close=>activate help/about=>activate))
94-
95-(defun setup-main-window ()
96- (let ((main-vbox (make-instance 'gtk:gtk-vbox
97- :border-width *sacked-padding*
98- :spacing *sacked-padding*))
99- (menu-bar (make-instance 'gtk:gtk-menu-bar))
100- (status-box (make-instance 'gtk:gtk-hbox
101- :border-width *sacked-padding*
102- :spacing *sacked-padding*))
103- (lbl-sacked (make-instance 'gtk:gtk-label
104- :label (format nil "~a v~a"
105- *sacked-long-name* *sacked-version*)
106- :xalign 0 :yalign 0)))
107-
108- ;; Assign main window
109- (setf *application-frame* (make-instance 'gtk:gtk-window
110- :title *sacked-long-name*
111- :width-request 720
112- :height-request 480))
113-
114- ;; Assign status bar label
115- (setf *status-label* (make-instance 'gtk:gtk-label
116- :label "Ready"
117- :xalign 0 :yalign 0))
118-
119- ;; Setup main window
120- (gobject:g-signal-connect *application-frame*
121- "delete-event" #'main-window=>delete-event)
122-
123- ;; Setup menu
124- (let* ((file-menu (make-instance 'gtk:gtk-menu))
125- (help-menu (make-instance 'gtk:gtk-menu))
126- (accelerators (make-instance 'gtk:gtk-accel-group))
127-
128- (file (make-instance 'gtk:gtk-menu-item :label "_File" :use-underline t))
129- (file/new (make-instance 'gtk:gtk-image-menu-item
130- :label "_New Sack" :use-underline t
131- :image (make-instance 'gtk:gtk-image :stock "gtk-new"
132- :icon-size 1)
133- :accel-group accelerators))
134-
135- (file/open (make-instance 'gtk:gtk-image-menu-item
136- :label "_Open Sack" :use-underline t
137- :image (make-instance 'gtk:gtk-image :stock "gtk-open"
138- :icon-size 1)
139- :accel-group accelerators))
140-
141- (file/close (make-instance 'gtk:gtk-image-menu-item
142- :label "_Close Sack" :use-underline t
143- :image (make-instance 'gtk:gtk-image :stock "gtk-close"
144- :icon-size 1)
145- :accel-group accelerators))
146-
147- (file/save (make-instance 'gtk:gtk-image-menu-item
148- :label "_Save Sack" :use-underline t
149- :image (make-instance 'gtk:gtk-image :stock "gtk-save"
150- :icon-size 1)
151- :accel-group accelerators))
152-
153- (file/save-as (make-instance 'gtk:gtk-image-menu-item
154- :label "Save Sack _As" :use-underline t
155- :image (make-instance 'gtk:gtk-image :stock "gtk-save-as"
156- :icon-size 1)
157- :accel-group accelerators))
158-
159- (file/quit (make-instance 'gtk:gtk-image-menu-item
160- :label "gtk-quit" :use-stock t
161- :accel-group accelerators))
162-
163- (help (make-instance 'gtk:gtk-menu-item :label "_Help" :use-underline t))
164- (help/about (make-instance 'gtk:gtk-image-menu-item
165- :label "gtk-about" :use-stock t)))
166-
167- ;; Accelerator stuff
168- (gtk:gtk-window-add-accel-group *application-frame* accelerators)
169-
170- (gtk:gtk-widget-add-accelerator file/new "activate" accelerators
171- (gdk:gdk-unicode-to-keyval #\n)
172- '(:control-mask) '(:visible))
173-
174- (gtk:gtk-widget-add-accelerator file/open "activate" accelerators
175- (gdk:gdk-unicode-to-keyval #\o)
176- '(:control-mask) '(:visible))
177-
178- (gtk:gtk-widget-add-accelerator file/close "activate" accelerators
179- (gdk:gdk-unicode-to-keyval #\w)
180- '(:control-mask :mod1-mask) '(:visible))
181-
182- (gtk:gtk-widget-add-accelerator file/save "activate" accelerators
183- (gdk:gdk-unicode-to-keyval #\s)
184- '(:control-mask) '(:visible))
185-
186- (gtk:gtk-widget-add-accelerator file/quit "activate" accelerators
187- (gdk:gdk-unicode-to-keyval #\q)
188- '(:control-mask) '(:visible))
189-
190- ;; Signals for the menu items
191- (gobject:g-signal-connect file/new "activate" #'file/new=>activate)
192- (gobject:g-signal-connect file/open "activate" #'file/open=>activate)
193- (gobject:g-signal-connect file/save "activate" #'file/save=>activate)
194- (gobject:g-signal-connect file/save-as "activate" #'file/save-as=>activate)
195- (gobject:g-signal-connect file/close "activate" #'file/close=>activate)
196- (gobject:g-signal-connect file/quit "activate" #'file/quit=>activate)
197- (gobject:g-signal-connect help/about "activate" #'help/about=>activate)
198-
199- ;; Build the menu
200- (setf (gtk:gtk-menu-item-submenu file) file-menu)
201- (gtk:gtk-menu-shell-append file-menu file/new)
202- (gtk:gtk-menu-shell-append file-menu file/open)
203- (gtk:gtk-menu-shell-append file-menu file/close)
204- (gtk:gtk-menu-shell-append file-menu (make-instance 'gtk:gtk-separator-menu-item))
205- (gtk:gtk-menu-shell-append file-menu file/save)
206- (gtk:gtk-menu-shell-append file-menu file/save-as)
207- (gtk:gtk-menu-shell-append file-menu (make-instance 'gtk:gtk-separator-menu-item))
208- (gtk:gtk-menu-shell-append file-menu file/quit)
209-
210- (gtk:gtk-menu-shell-append menu-bar file)
211-
212- (setf (gtk:gtk-menu-item-submenu help) help-menu)
213- (gtk:gtk-menu-shell-append help-menu help/about)
214-
215- (gtk:gtk-menu-shell-append menu-bar help))
216-
217- ;; Setup tree view
218- (let ((type-col (make-instance 'gtk:gtk-tree-view-column :title "Type" :resizable t
219- :min-width 60))
220- (name-col (make-instance 'gtk:gtk-tree-view-column :title "Name" :resizable t
221- :min-width 60
222- :expand t))
223- (size-col (make-instance 'gtk:gtk-tree-view-column :title "Size" :resizable t
224- :min-width 90))
225-
226- (cell-rend (make-instance 'gtk:gtk-cell-renderer-text)))
227-
228- (setf *tree-store* (make-instance 'gtk:gtk-list-store
229- :column-types '("gchararray" "gchararray"
230- "gchararray")))
231- (setf *tree-view* (make-instance 'gtk:gtk-tree-view :model *tree-store*))
232-
233- (gtk:gtk-tree-view-column-pack-start type-col cell-rend)
234- (gtk:gtk-tree-view-column-pack-start name-col cell-rend)
235- (gtk:gtk-tree-view-column-pack-start size-col cell-rend)
236-
237- (gtk:gtk-tree-view-column-add-attribute name-col cell-rend "text" *tree-store-name-col*)
238- (gtk:gtk-tree-view-column-add-attribute type-col cell-rend "text" *tree-store-type-col*)
239- (gtk:gtk-tree-view-column-add-attribute size-col cell-rend "text" *tree-store-size-col*)
240-
241- (gtk:gtk-tree-view-append-column *tree-view* type-col)
242- (gtk:gtk-tree-view-append-column *tree-view* name-col)
243- (gtk:gtk-tree-view-append-column *tree-view* size-col))
244-
245- ;; Setup status bar
246- (gtk:gtk-box-pack-start status-box lbl-sacked :expand nil :fill nil)
247- (gtk:gtk-box-pack-end status-box *status-label* :expand nil :fill t)
248-
249- ;; Pack main box
250- (let ((scroll (make-instance 'gtk:gtk-scrolled-window
251- :vscrollbar-policy :automatic
252- :hscrollbar-policy :automatic)))
253- (gtk:gtk-container-add scroll *tree-view*)
254-
255- (gtk:gtk-box-pack-start main-vbox menu-bar :expand nil :fill t)
256- (gtk:gtk-box-pack-start main-vbox scroll :expand t :fill t)
257- (gtk:gtk-box-pack-start main-vbox status-box :expand nil :fill t))
258-
259- (gtk:gtk-container-add *application-frame* main-vbox)
260- (gtk:gtk-widget-show-all *application-frame*)))
261-
262-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
263-
264-(defun main ()
265- (log-message "Initializing")
266- (sb-ext:gc :full t)
267- (setf *loaded-sack* (cl-sack:make-sack-file))
268-
269- (gtk:within-main-loop
270- (log-message "Setting up main window")
271- (setup-main-window)
272-
273- (log-message "Initialization finished")
274-
275- (update-main-window))
276- (gtk:join-gtk-main))
diff -r ab684d1d1152 -r c9f6ddba5fab gsacked-src/util.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gsacked-src/util.lisp Fri Feb 08 16:45:39 2019 -0700
@@ -0,0 +1,30 @@
1+;;;; GSacked - A graphical tool to create and edit Sack files
2+;;;; Copyright (C) 2016-2019 Alexa Jones-Gonzales <alexa@partition36.com>
3+;;;;
4+;;;; This program is free software: you can redistribute it and/or modify
5+;;;; it under the terms of the GNU General Public License as published by
6+;;;; the Free Software Foundation, either version 3 of the License, or
7+;;;; (at your option) any later version.
8+;;;;
9+;;;; This program is distributed in the hope that it will be useful,
10+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12+;;;; GNU General Public License for more details.
13+;;;;
14+;;;; You should have received a copy of the GNU General Public License
15+;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
16+(in-package :p36.gsacked)
17+
18+(defmacro assert-or-die (test msg &rest fmt-args)
19+ `(unless ,test
20+ (error ,msg ,@fmt-args)))
21+
22+(defmacro die-now (msg &rest args)
23+ "Prints an error message to *ERROR-OUTPUT*, then kills the program
24+unless Swank is found. If Swank is found, only the message gets
25+printed."
26+ `(progn
27+ (p36-log:flog () ,msg ,@args)
28+ (if (find-package :swank)
29+ (error "DIE-NOW called!")
30+ (p36:exit 255))))
diff -r ab684d1d1152 -r c9f6ddba5fab gsacked-src/utilities.lisp
--- a/gsacked-src/utilities.lisp Wed Feb 06 23:25:44 2019 -0700
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,35 +0,0 @@
1-;;;; GSacked - A graphical tool to create and edit Sack files
2-;;;; Copyright (C) 2016 Alexa Jones-Gonzales <alexa@partition36.com>
3-;;;;
4-;;;; This program is free software: you can redistribute it and/or modify
5-;;;; it under the terms of the GNU General Public License as published by
6-;;;; the Free Software Foundation, either version 3 of the License, or
7-;;;; (at your option) any later version.
8-;;;;
9-;;;; This program is distributed in the hope that it will be useful,
10-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12-;;;; GNU General Public License for more details.
13-;;;;
14-;;;; You should have received a copy of the GNU General Public License
15-;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
16-
17-(in-package :p36.gsacked)
18-
19-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
20-;;;
21-;;; Utility Functions
22-;;;
23-
24-(defun log-message-no-newline (format-string &rest args)
25- (format *log-output* "[~a]: ~?" *sacked-name* format-string args)
26- (finish-output *log-output*))
27-
28-(defun log-message (format-string &rest args)
29- (log-message-no-newline format-string args)
30- (format *log-output* "~%")
31- (finish-output *log-output*))
32-
33-(defun do-normal-quit ()
34- (log-message "~a is now exiting" *sacked-long-name*)
35- (gtk:leave-gtk-main))
diff -r ab684d1d1152 -r c9f6ddba5fab gsacked.asd
--- a/gsacked.asd Wed Feb 06 23:25:44 2019 -0700
+++ b/gsacked.asd Fri Feb 08 16:45:39 2019 -0700
@@ -23,9 +23,10 @@
2323
2424 (asdf:defsystem gsacked
2525 :name "GSacked"
26+ :long-name "GSacked"
2627 :description "A graphical tool to create and edit Sack files"
2728
28- :version "1.0"
29+ :version "0.1"
2930 :license "GPLv3 (see LICENSE for details)"
3031
3132 :maintainer "Alexa Jones-Gonzales"
@@ -34,19 +35,20 @@
3435 :defsystem-depends-on (:cl-sack
3536 :cl-arg-parser
3637 :p36-lib
37- :cl-cffi-gtk)
38- ;;:cl-gtk2-gtk)
39- ;;:mcclim)
38+ :p36-log
39+ :mcclim)
4040
41+ :serial t
4142 :components
4243 ((:module
4344 "gsacked-src"
44- :components ((:file "package")
45- (:file "globals" :depends-on ("package"))
46- (:file "utilities" :depends-on ("globals"))
47- (:file "message-handler" :depends-on ("package" "globals"))
45+ :components
46+ ((:file "package")
47+ (:file "globals")
48+ (:file "util")
4849
49- (:file "sacked-gui" :depends-on ("message-handler" "utilities"))
50- (:file "main-window-menu-events" :depends-on ("sacked-gui"))))))
50+ (:file "gui-main-window")
51+
52+ (:file "main")))))
5153
5254 ;;;; EOF
Show on old repository browser