← Back to branch summary

~ubuntu-branches/ubuntu/trusty/mit-scheme/trusty-proposed

« back to all changes in this revision

Viewing changes to src/edwin/dired.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2006-09-20 21:59:42 UTC
  • mfrom: (1.1.4 upstream) (3.1.1 etch)
  • Revision ID: james.westby@ubuntu.com-20060920215942-o3erry1wowyk1ezz
Tags: 7.7.90+20060906-3
No changes; rebuild with downgraded openssl in order to permit
transition into testing.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/edwin/dired.scm
1
1
#| -*-Scheme-*-
2
2
 
3
 
$Id: dired.scm,v 1.194 2004/03/30 04:45:01 cph Exp $
 
3
$Id: dired.scm,v 1.199 2006/06/12 04:19:43 cph Exp $
4
4
 
5
 
Copyright 1986, 1989-2001 Massachusetts Institute of Technology
 
5
Copyright 1987,1989,1991,1992,1993,1994 Massachusetts Institute of Technology
 
6
Copyright 1995,1996,1997,1999,2000,2001 Massachusetts Institute of Technology
 
7
Copyright 2004,2006 Massachusetts Institute of Technology
6
8
 
7
9
This file is part of MIT/GNU Scheme.
8
10
 
287
289
  "Read the current buffer."
288
290
  ()
289
291
  (lambda ()
290
 
    (revert-buffer (current-buffer) true true)))
 
292
    (revert-buffer (current-buffer) #t #t)))
291
293
 
292
294
(define-command dired-flag-file-deletion
293
295
  "Mark the current file to be killed."
509
511
                        (string-append (string-head (car switches) index)
510
512
                                       (string-tail (car switches)
511
513
                                                    (fix:+ index 1))))
512
 
                       (s2 (reduce string-append-separated "" (cdr switches))))
 
514
                       (s2
 
515
                        (reduce-right string-append-separated
 
516
                                      ""
 
517
                                      (cdr switches))))
513
518
                   (if (string=? "-" s1)
514
519
                       s2
515
520
                       (string-append-separated s1 s2)))
691
696
      (list (prompt-for-directory (if argument
692
697
                                      "List directory (verbose)"
693
698
                                      "List directory (brief)")
694
 
                                  false)
 
699
                                  #f)
695
700
            argument)))
696
701
  (lambda (directory argument)
697
702
    (let ((directory (->pathname directory))
709
714
                        point))
710
715
      (set-buffer-point! buffer (buffer-start buffer))
711
716
      (buffer-not-modified! buffer)
712
 
      (pop-up-buffer buffer false))))
 
717
      (pop-up-buffer buffer #f))))
713
718
 
714
719
;;;; Utilities
715
720
 
716
721
(define (dired-filename-start lstart)
717
 
  (let ((eol (line-end lstart 0)))
718
 
    (let ((m
719
 
           (re-search-forward
720
 
            "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ ]+[0-9]+"
721
 
            lstart
722
 
            eol
723
 
            false)))
724
 
      (and m
725
 
           (re-match-forward " *[^ ]* *" m eol)))))
 
722
  (re-match-forward directory-listing-before-filename-regexp
 
723
                    lstart
 
724
                    (line-end lstart 0)
 
725
                    #f))
726
726
 
727
727
(define (dired-filename-string lstart)
728
728
  (let ((start (dired-filename-start lstart)))
789
789
      (move-mark-to! point (line-start point 1)))
790
790
    (mark-temporary! point)))
791
791
 
 
792
;;; Regular expression to match up to the file name in a directory
 
793
;;; listing.  The default value is designed to recognize dates and
 
794
;;; times regardless of the language.
 
795
 
 
796
;;; Stolen from Emacs 22 and translated to REXP format.
 
797
 
 
798
(define directory-listing-before-filename-regexp
 
799
  (let* ((l
 
800
          (char-set-union char-set:alphabetic
 
801
                          (ascii-range->char-set #x80 #x100)))
 
802
         (l? (rexp-optional l))
 
803
         (l-or-quote (char-set-union l (char-set #\')))
 
804
         (digit (string->char-set "0123456789"))
 
805
         ;; In some locales, month abbreviations are as short as 2 letters,
 
806
         ;; and they can be followed by ".".
 
807
         ;; In Breton, a month name  can include a quote character.
 
808
         (month
 
809
          (rexp-sequence (rexp-n* 2 l-or-quote)
 
810
                         (rexp-optional ".")))
 
811
         (s " ")
 
812
         (s+ (rexp+ s))
 
813
         (yyyy (rexp-n*n 4 char-set:numeric))
 
814
         (dd (rexp-sequence (string->char-set " 0123") digit))
 
815
         (HH:MM (rexp-sequence (string->char-set " 012")
 
816
                               digit
 
817
                               (string->char-set ":.")
 
818
                               (string->char-set "012345")
 
819
                               digit))
 
820
         (seconds (rexp-sequence (string->char-set "0123456")
 
821
                                 digit
 
822
                                 (rexp-optional (string->char-set ".,")
 
823
                                                (rexp+ digit))))
 
824
         (zone (rexp-sequence (string->char-set "-+")
 
825
                              (string->char-set "012")
 
826
                              digit
 
827
                              (string->char-set "012345")
 
828
                              digit))
 
829
         (iso-mm-dd (rexp-sequence (string->char-set "01")
 
830
                                   digit
 
831
                                   "-"
 
832
                                   (string->char-set "0123")
 
833
                                   digit))
 
834
         (iso-time
 
835
          (rexp-sequence HH:MM
 
836
                         (rexp-optional ":"
 
837
                                        seconds
 
838
                                        (rexp-optional (rexp-optional s)
 
839
                                                       zone))))
 
840
         (iso
 
841
          (rexp-alternatives (rexp-sequence (rexp-optional yyyy "-")
 
842
                                            iso-mm-dd
 
843
                                            (string->char-set " T")
 
844
                                            iso-time)
 
845
                             (rexp-sequence yyyy
 
846
                                            "-"
 
847
                                            iso-mm-dd)))
 
848
         (western
 
849
          (rexp-sequence
 
850
           (rexp-alternatives (rexp-sequence month s+ dd)
 
851
                              (rexp-sequence dd (rexp-optional ".") s month))
 
852
           s+
 
853
           (rexp-alternatives HH:MM yyyy)))
 
854
         (western-comma
 
855
          (rexp-sequence month s+ dd "," s+ yyyy))
 
856
         ;; Japanese MS-Windows ls-lisp has one-digit months, and
 
857
         ;; omits the Kanji characters after month and day-of-month.
 
858
         ;; On Mac OS X 10.3, the date format in East Asian locales is
 
859
         ;; day-of-month digits followed by month digits.
 
860
         (mm (rexp-sequence (rexp-optional (string->char-set " 01"))
 
861
                            digit))
 
862
         (east-asian
 
863
          (rexp-sequence
 
864
           (rexp-alternatives (rexp-sequence mm l? s dd l? s+)
 
865
                              (rexp-sequence dd s mm s+))
 
866
           (rexp-alternatives HH:MM
 
867
                              (rexp-sequence yyyy l?)))))
 
868
    ;; The "[0-9]" below requires the previous column to end in a digit.
 
869
    ;; This avoids recognizing `1 may 1997' as a date in the line:
 
870
    ;; -r--r--r--   1 may      1997        1168 Oct 19 16:49 README
 
871
 
 
872
    ;; The "[BkKMGTPEZY]?" below supports "ls -alh" output.
 
873
    ;; The ".*" below finds the last match if there are multiple matches.
 
874
    ;; This avoids recognizing `jservice  10  1024' as a date in the line:
 
875
    ;; drwxr-xr-x  3 jservice  10  1024 Jul  2  1997 esg-host
 
876
 
 
877
    ;; vc dired listings provide the state or blanks between file
 
878
    ;; permissions and date.  The state is always surrounded by
 
879
    ;; parentheses:
 
880
    ;; -rw-r--r-- (modified) 2005-10-22 21:25 files.el
 
881
    ;; Support for this was added to Edwin by cph.
 
882
    (rexp-compile
 
883
     (rexp-sequence (rexp* (rexp-any-char))
 
884
                    (rexp-alternatives
 
885
                     (rexp-sequence digit
 
886
                                    (rexp-optional
 
887
                                     (string->char-set "BkKMGTPEZY")))
 
888
                     ")")
 
889
                    s+
 
890
                    (rexp-alternatives western
 
891
                                       western-comma
 
892
                                       east-asian
 
893
                                       iso)
 
894
                    s+))))
 
895
 
792
896
(define (dired-redisplay pathname #!optional mark)
793
897
  (let ((lstart
794
898
         (mark-right-inserting-copy