src/main.lisp @ 84fa1724b747 default tip

(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*))))