Changeset 9152


Ignore:
Timestamp:
Apr 14, 2008, 3:30:23 PM (11 years ago)
Author:
gz
Message:

Add svn hacking fns from trunk, and propagate r9151 from trunk

Location:
branches/working-0711/ccl/lib
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/lib/compile-ccl.lisp

    r9117 r9152  
    608608        (run-program "svn" '("update")))
    609609      (let* ((svn (probe-file "ccl:.svn;entries"))
    610              (repo (and svn
    611                         (with-open-file (s svn)
    612                           (loop as line =  (read-line s nil) while line
    613                              do (when (search "://" line)
    614                                   (setq line (read-line s))
    615                                   (return (and (search "://" line) line)))))))
     610             (repo (and svn (svn-repository)))
    616611             (s (make-string-output-stream)))
    617612        (when repo
     
    632627    ;; it without making the test suite non-portable across platforms...
    633628    (handler-bind ((warning (lambda (c)
    634                               (when (and (typep c 'compiler-warning)
    635                                          (eq (compiler-warning-warning-type c) :program-error)
    636                                          (typep (car (compiler-warning-args c)) 'simple-warning)
    637                                          (or
    638                                           (string-equal
    639                                            (simple-condition-format-control (car (compiler-warning-args c)))
    640                                            "Clause ~S ignored in ~S form - shadowed by ~S .")
    641                                           ;; Might as well ignore these as well, they're intentional.
    642                                           (string-equal
    643                                            (simple-condition-format-control (car (compiler-warning-args c)))
    644                                            "Duplicate keyform ~s in ~s statement.")))
     629                              (when (let ((w (or (and (typep c 'compiler-warning)
     630                                                      (eq (compiler-warning-warning-type c) :program-error)
     631                                                      (car (compiler-warning-args c)))
     632                                                 c)))
     633                                      (and (typep w 'simple-warning)
     634                                           (or
     635                                            (string-equal
     636                                             (simple-condition-format-control w)
     637                                             "Clause ~S ignored in ~S form - shadowed by ~S .")
     638                                            ;; Might as well ignore these as well, they're intentional.
     639                                            (string-equal
     640                                             (simple-condition-format-control w)
     641                                             "Duplicate keyform ~s in ~s statement."))))
    645642                                (muffle-warning c)))))
    646643      ;; This loads the infrastructure
  • branches/working-0711/ccl/lib/misc.lisp

    r8421 r9152  
    395395          (ecase internal-time-units-per-second
    396396            (1000000 6)
    397             (100  3)))
     397            (1000  3)))
    398398         (cpu-count (cpu-count)))
    399399    (format s "~&~S took ~:D ~a (~,vF seconds) to run ~%~20twith ~D available CPU core~P."
     
    709709(%fhave 'df #'disassemble)
    710710
     711(defun svn-info-component (component)
     712  (let* ((component-length (length component)))
     713  (with-output-to-string (s)
     714    (multiple-value-bind (status exit-code)
     715        (external-process-status
     716         (run-program "svn"  (list "info" (native-translated-namestring "ccl:")):output s))
     717      (when (and (eq :exited status) (zerop exit-code))
     718        (with-input-from-string (output (get-output-stream-string s))
     719            (do* ((line (read-line output nil nil) (read-line output nil nil)))
     720                 ((null line))
     721              (when (and (>= (length line) component-length)
     722                         (string= component line :end2 component-length))
     723                (return-from svn-info-component
     724                  (string-trim " " (subseq line component-length)))))))))))
     725
     726(defun svn-url () (svn-info-component "URL:"))
     727(defun svn-repository () (svn-info-component "Repository Root:"))
     728
     729;;; Try to say something about what tree (trunk, a branch, a release)
     730;;; we were built from. If the URL (relative to the repository)
     731;;; starts with "branches", return the second component of the
     732;;; relative URL, otherwise return the first component.
     733(defun svn-tree ()
     734  (let* ((repo (svn-repository))
     735         (url (svn-url)))
     736    (or
     737     (if (and repo url)
     738       (let* ((repo-len (length repo)))
     739         (when (and (> (length url) repo-len)
     740                    (string= repo url :end2 repo-len))
     741           ;; Cheat: do pathname parsing here.
     742           (let* ((path (pathname (ensure-directory-namestring (subseq url repo-len))))
     743                  (dir (cdr (pathname-directory path))))
     744             (when (string= "ccl" (car (last dir)))
     745               (let* ((base (car dir)))
     746                 (unless (or (string= base "release")
     747                             (string= base "releases"))
     748                   (if (string= base "branches")
     749                     (cadr dir)
     750                     (car dir))))))))))))
     751
     752
     753
     754       
     755                         
    711756(defun local-svn-revision ()
    712757  (or
     
    718763    (multiple-value-bind (status exit-code)
    719764        (external-process-status
    720          (run-program "svnversion"  (list  (native-translated-namestring "ccl:") "/trunk/ccl"):output s))
     765         (run-program "svnversion"  (list  (native-translated-namestring "ccl:") (or (svn-url) "")):output s))
    721766      (when (and (eq :exited status) (zerop exit-code))
    722767        (with-input-from-string (output (get-output-stream-string s))
Note: See TracChangeset for help on using the changeset viewer.