--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore Sun Jul 19 18:24:27 2020 -0400
@@ -0,0 +1,3 @@
+syntax:regex
+^c$
+^e$
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile Sun Jul 19 18:24:27 2020 -0400
@@ -0,0 +1,11 @@
+.PHONY: all
+
+sources := $(shell hg files)
+
+all: c e
+
+c: $(sources)
+ sbcl --eval '(ql:quickload :tdcb)' --eval '(tdcb/main:build/compress)'
+
+e: $(sources)
+ sbcl --eval '(ql:quickload :tdcb)' --eval '(tdcb/main:build/extract)'
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/main.lisp Sun Jul 19 18:24:27 2020 -0400
@@ -0,0 +1,97 @@
+(in-package :tdcb/main)
+
+(defparameter *version* "0.0.0")
+(defparameter *compressors* (make-hash-table :test #'equal))
+(defparameter *extractors* (make-hash-table :test #'equal))
+
+(defun ensure-compressor (name summary function)
+ (setf (gethash name *compressors*) (cons summary function)))
+
+(defun ensure-extractor (name summary function)
+ (setf (gethash name *extractors*) (cons summary function)))
+
+(defparameter *option-help*
+ (adopt:make-option 'help
+ :help "Print help and exit."
+ :long "help"
+ :short #\h
+ :reduce (constantly t)))
+
+(defparameter *option-version*
+ (adopt:make-option 'version
+ :help "Print version information and exit."
+ :long "version"
+ :reduce (constantly t)))
+
+(defparameter *option-algorithms*
+ (adopt:make-option 'algorithms
+ :help "Print a list of available algorithms and exit."
+ :long "algorithms"
+ :short #\A
+ :reduce (constantly t)))
+
+(adopt:define-string *help-compress*
+ "This program compresses files using one of a variety of compression algorithms.~@
+ ~@
+ Use --algorithms to view a list of available algorithms.")
+
+(adopt:define-string *help-extract*
+ "This program extracts files that were compressed using one of a variety of ~
+ compression algorithms.~@
+ ~@
+ Use --algorithms to view a list of available algorithms.")
+
+(defparameter *compress-ui*
+ (adopt:make-interface
+ :name "c"
+ :summary "compress files with a variety of algorithms"
+ :usage "ALGORITHM [OPTIONS] [FILE...]"
+ :help *help-compress*
+ :contents (list
+ *option-help*
+ *option-version*
+ *option-algorithms*)))
+
+(defparameter *extract-ui*
+ (adopt:make-interface
+ :name "e"
+ :summary "extract files with a variety of algorithms"
+ :usage "ALGORITHM [OPTIONS] [FILE...]"
+ :help *help-extract*
+ :contents (list
+ *option-help*
+ *option-version*
+ *option-algorithms*)))
+
+(defun print-algorithms (algorithms)
+ (maphash (lambda (name value)
+ (format t "~A - ~A" name (first value)))
+ algorithms))
+
+(defun toplevel (ui algorithms)
+ (handler-case
+ (handler-bind ((adopt:unrecognized-option #'adopt:treat-as-argument))
+ (multiple-value-bind (arguments options) (adopt:parse-options ui)
+ (cond
+ ((gethash 'help options) (adopt:print-help-and-exit ui))
+ ((gethash 'version options) (write-line *version*) (adopt:exit))
+ ((gethash 'algorithms options) (print-algorithms algorithms) (adopt:exit))
+ ((null arguments) (adopt:print-help-and-exit ui :stream *error-output* :exit-code 1))
+ (t (let ((algorithm (gethash (first arguments) algorithms)))
+ (if algorithm
+ (funcall (second algorithm) (rest arguments))
+ (error "Unknown algorithm ~S." (first arguments))))))))
+ (error (e) (adopt:print-error-and-exit e))))
+
+(defun build/compress ()
+ (sb-ext:save-lisp-and-die "c"
+ :executable t
+ :save-runtime-options t
+ :toplevel (lambda () (toplevel *compress-ui* *compressors*))))
+
+(defun build/extract ()
+ (sb-ext:save-lisp-and-die
+ "e"
+ :executable t
+ :save-runtime-options t
+ :toplevel (lambda () (toplevel *extract-ui* *extractors*))))
--- a/src/package.lisp Sat Jul 18 22:49:13 2020 -0400
+++ b/src/package.lisp Sun Jul 19 18:24:27 2020 -0400
@@ -1,3 +1,11 @@
(defpackage :tdcb
(:use :cl)
(:export))
+
+(defpackage :tdcb/main
+ (:use :cl)
+ (:export
+ :build/compress
+ :build/extract
+ :ensure-compressor
+ :ensure-extractor))
--- a/tdcb.asd Sat Jul 18 22:49:13 2020 -0400
+++ b/tdcb.asd Sun Jul 19 18:24:27 2020 -0400
@@ -4,12 +4,13 @@
:license "MIT"
- :depends-on ()
+ :depends-on (:adopt)
:serial t
:components ((:module "src" :serial t
:components ((:file "package")
(:file "utilities")
- (:file "bits")))))
+ (:file "bits")
+ (:file "main")))))