version.lisp 5.97 KB
Newer Older
1 2 3 4 5 6 7 8
;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               version.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;    
9 10
;;;;    This file defines contains the *version* variable,
;;;;    and the VERSION function.
11 12 13 14
;;;;    
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
15
;;;;    2012-02-20 <PJB> Added auto-decrement of version number.
16 17 18
;;;;    2012-02-15 <PJB> Created.
;;;;BUGS
;;;;LEGAL
19
;;;;    AGPL3
20
;;;;    
21
;;;;    Copyright Pascal J. Bourguignon 2012 - 2014
22
;;;;    
23 24 25 26
;;;;    This program is free software: you can redistribute it and/or modify
;;;;    it under the terms of the GNU Affero General Public License as published by
;;;;    the Free Software Foundation, either version 3 of the License, or
;;;;    (at your option) any later version.
27
;;;;    
28 29 30 31
;;;;    This program is distributed in the hope that it will be useful,
;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;;    GNU Affero General Public License for more details.
32
;;;;    
33 34
;;;;    You should have received a copy of the GNU Affero General Public License
;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
35
;;;;**************************************************************************
36 37
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf *readtable* (copy-readtable nil)))
38 39 40
(in-package "COM.INFORMATIMAGO.LSE")


41 42 43
(eval-when (:compile-toplevel :load-toplevel :execute)

  (defparameter *version*
44 45
    #. (let ((*read-default-float-format* 'double-float))
         (format nil "1.0.0-~8,6F" (decf (SEXP-FILE-CONTENTS
46
                                          (make-pathname :name "VERSION" :type nil :version nil
47 48
                                                         :defaults (or *load-truename*
                                                                       *compile-file-truename*))
49
                                          :if-does-not-exist :create)
50
                                         0.000001d0)))
51
    "The version of the NASIUM L.S.E system.")
52 53 54


  (defparameter  *license*
55 56 57 58 59 60 61 62 63 64
    #. (TEXT-FILE-CONTENTS
        (merge-pathnames
         (make-pathname :directory '(:relative :up)
                        :name nil :type nil :version nil
                        :defaults (or *load-truename*
                                      *compile-file-truename*))
         (make-pathname :name "COPYING" :type nil :version nil
                        :defaults (or *load-truename*
                                      *compile-file-truename*))
         nil))))
65 66


67
(defvar *title-banner* "
68

69 70 71
NASIUM L.S.E.
LANGAGE SYMBOLIQUE D'ENSEIGNEMENT
VERSION ~A
72
~A
73 74 75

DISTRIBUE SELON LES TERMES DE LA LICENCE AGPLv3.
")
76

77

78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96
(defun system-release ()
  ;; TODO: 
  "")

(defvar *actual-version* nil)

(defun version ()
  (or *actual-version*
      (setf *actual-version*
            (format nil "~:@(~A-~A-~A~)" *version*
                         (or (cdr (assoc (lisp-implementation-type)
                                         '(("Armed Bear Common Lisp" . "abcl")
                                           ("Clozure Common Lisp"    . "ccl")
                                           ("CLISP"                  . "clisp")
                                           ("CMU Common Lisp"        . "cmucl")
                                           ("ECL"                    . "ecl")
                                           ("SBCL"                   . "sbcl"))
                                         :test (function string-equal)))
                             "cl")
97 98 99 100 101 102 103 104
                         (or
                          #+darwin                  "darwin" ;; (system-release)
                          #+(and bsd (not darwin))  "bsd"
                          #+linux                   "linux"
                          #+(or win32 windows)      "windows"
                          #+(and (not (or bsd darwin linux win32 windows)) unix) "unix"
                          #+(not (or bsd darwin linux unix win32 windows)) "generic")))))

105 106 107 108

(defun shell-command-to-string (command)
  "Execute the COMMAND with asdf:run-shell-command and returns its
stdout in a string (going thru a file)."
109 110
  (let ((path (namestring (merge-pathnames (format nil "out-~36,8,'0R.txt" (random (expt 2 32)))
                                           (user-homedir-pathname)))))
111 112 113 114 115 116 117 118 119
    (unwind-protect
         (when (zerop (asdf:run-shell-command (format nil "~A > ~S" command path)))
           (with-output-to-string (out)
             (with-open-file (file path)
               (loop
                 :for line = (read-line file nil nil)
                 :while line :do (write-line line out)))))
      (ignore-errors (delete-file path)))))

120 121 122
(eval-when (:compile-topleve)
  (warn "BUG: commit works when the current working directory is the git clone directory."))

123 124
(defun commit ()
  (string-trim #(#\Newline)
125
               (shell-command-to-string "(git log -1|sed -n -e 's/^commit //p')")))
126 127 128 129
(defvar *commit* (load-time-value (commit)))

(defun long-version ()
  (multiple-value-bind (se mi ho da mo ye) (decode-universal-time (get-universal-time))
130
    (format nil "~A,~% commit ~A,~% compiled ~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D,~% ~
131 132 133
                 on ~A,~% with features ~A."
            (version) *commit* ye mo da ho mi se
            (machine-instance) 
134 135 136 137
            (list #+:lse-mitra-15 :lse-mitra-15
                  #+:lse-t1600 :lse-t1600
                  #+:lse-unix :lse-unix
                  #+:lse-extensions :lse-extensions
138
                  #+lse-server :lse-server
139 140 141 142
                  #+:lse-case-insensitive :lse-case-insensitive
                  #+:debugging :debugging
                  #+:lse-scanner-debug :lse-scanner-debug))))

143

144 145 146 147
(defun versions ()
  "
RETURN: A list of three strings, the version, the short version and the long version.
"
148
  (list (version) *version* (long-version)))
149

150

151
;;;; THE END ;;;;