diff options
Diffstat (limited to 'test')
| -rw-r--r-- | test/ChangeLog | 76 | ||||
| -rw-r--r-- | test/comint-testsuite.el | 60 | ||||
| -rw-r--r-- | test/icalendar-testsuite.el | 206 | ||||
| -rw-r--r-- | test/indent/Makefile | 15 | ||||
| -rw-r--r-- | test/indent/modula2.mod | 53 | ||||
| -rw-r--r-- | test/indent/octave.m | 2324 | ||||
| -rw-r--r-- | test/indent/prolog.prolog | 224 | ||||
| -rw-r--r-- | test/occur-testsuite.el | 347 | ||||
| -rw-r--r-- | test/redisplay-testsuite.el | 69 |
9 files changed, 3327 insertions, 47 deletions
diff --git a/test/ChangeLog b/test/ChangeLog index e030322c83e..3b1921c5987 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,3 +1,63 @@ +2010-11-11 Stefan Monnier <monnier@iro.umontreal.ca> + + * indent/modula2.mod: New file. + +2010-10-27 Stefan Monnier <monnier@iro.umontreal.ca> + + * indent/octave.m: Add a test to ensure indentation is local. + +2010-10-23 Glenn Morris <rgm@gnu.org> + + * comint-testsuite.el + (comint-testsuite--test-comint-password-prompt-regexp): + Add "Please enter the password". (Bug#7224) + +2010-09-20 Stefan Monnier <monnier@iro.umontreal.ca> + + * indent/prolog.prolog: Use normal spacing around !. + +2010-09-18 Stefan Monnier <monnier@iro.umontreal.ca> + + * indent/octave.m: Remove one more `fixindent'. Use `end'. + +2010-09-10 Stefan Monnier <monnier@iro.umontreal.ca> + + * indent/octave.m: Remove some `fixindent' not needed any more. + +2010-08-30 Stefan Monnier <monnier@iro.umontreal.ca> + + * indent/octave.m: New file. + +2010-08-08 Ulf Jasper <ulf.jasper@web.de> + + * icalendar-testsuite.el (icalendar-testsuite-run): Add internal tests. + (icalendar-testsuite--trim, icalendar-testsuite--compare-strings) + (icalendar-testsuite--run-internal-tests): New. + (icalendar-testsuite--test-convert-ordinary-to-ical) + (icalendar-testsuite--test-convert-block-to-ical) + (icalendar-testsuite--test-convert-anniversary-to-ical) + (icalendar-testsuite--test-parse-vtimezone) + (icalendar-testsuite--do-test-export): Code formatting. + (icalendar-testsuite--test-parse-vtimezone): Doc fix. + (icalendar-testsuite--do-test-import) + (icalendar-testsuite--do-test-cycle): + Use icalendar-testsuite--compare-strings + (icalendar-testsuite--run-import-tests): Comment added. + (icalendar-testsuite--run-import-tests) + (icalendar-testsuite--run-real-world-tests): Fix expected results. + +2010-06-25 Chong Yidong <cyd@stupidchicken.com> + + * redisplay-testsuite.el (test-redisplay-3): New test. + +2010-06-11 Chong Yidong <cyd@stupidchicken.com> + + * comint-testsuite.el: New file. + +2010-06-02 Stefan Monnier <monnier@iro.umontreal.ca> + + * indent: New dir. + 2010-05-07 Chong Yidong <cyd@stupidchicken.com> * Version 23.2 released. @@ -30,8 +90,20 @@ * cedet/tests/testdoublens.cpp: * cedet/tests/testdoublens.hpp: Add copyright header. - * cedet/semantic-tests.el (semanticdb-test-gnu-global): Remove - reference to deleted files. + * cedet/semantic-tests.el (semanticdb-test-gnu-global): + Remove reference to deleted files. + +2010-03-30 Juri Linkov <juri@jurta.org> + + * occur-testsuite.el (occur-tests): Add tests for context lines. + +2010-03-23 Juri Linkov <juri@jurta.org> + + * occur-testsuite.el: New file. + +2010-03-10 Chong Yidong <cyd@stupidchicken.com> + + * Branch for 23.2. 2010-02-19 Ulf Jasper <ulf.jasper@web.de> diff --git a/test/comint-testsuite.el b/test/comint-testsuite.el new file mode 100644 index 00000000000..9a4e7eae3b7 --- /dev/null +++ b/test/comint-testsuite.el @@ -0,0 +1,60 @@ +;;; bytecomp-testsuite.el + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for comint and related modes. + +;;; Code: + +(require 'comint) + +(defun comint-testsuite-run () + (interactive) + (with-output-to-temp-buffer "*comint test*" + (comint-testsuite--test-comint-password-prompt-regexp))) + +(defun comint-testsuite--test-comint-password-prompt-regexp () + (interactive) + (let ((password-strings + '("foo@example.net's password: " ;ssh + "Password for foo@example.org: " ; kinit + "Please enter the password for foo@example.org: " ; kinit + "Kerberos password for devnull/root <at> GNU.ORG: " ; ksu + "Enter passphrase: " ; ssh-add + "Enter passphrase (empty for no passphrase): " ; ssh-keygen + "Enter same passphrase again: " ; ssh-keygen + "Passphrase for key root@GNU.ORG: " ; plink + "[sudo] password for user:" ; Ubuntu sudo + "Password (again):" + "Enter password:")) + fail) + (dolist (str password-strings) + (unless (string-match comint-password-prompt-regexp str) + (setq fail t) + (princ (format " ERROR: comint-password-prompt-regexp did not match %s\n" + str)))) + (if fail + (princ "FAILED: comint-password-prompt-regexp test\n") + (princ "PASSED: comint-password-prompt-regexp test\n")))) + +(provide 'comint-testsuite) + +;;; comint-testsuite.el ends here + diff --git a/test/icalendar-testsuite.el b/test/icalendar-testsuite.el index 012f586c342..351bd528bcb 100644 --- a/test/icalendar-testsuite.el +++ b/test/icalendar-testsuite.el @@ -33,6 +33,7 @@ (defun icalendar-testsuite-run () "Run icalendar test suite." (interactive) + (icalendar-testsuite--run-internal-tests) (icalendar-testsuite--run-function-tests) (icalendar-testsuite--run-import-tests) (icalendar-testsuite--run-export-tests) @@ -41,6 +42,44 @@ (message "All icalendar tests finished successfully.")) ;; ====================================================================== +;; internal +;; ====================================================================== +(defun icalendar-testsuite--trim (string) + "Remove leading and trailing whitespace from STRING." + (replace-regexp-in-string "[ \t\n]+\\'" "" + (replace-regexp-in-string "\\`[ \t\n]+" "" string))) + +(defun icalendar-testsuite--compare-strings (str1 str2) + "Compare strings STR1 and STR2. +Return t if strings are equal, else return substring indicating first difference. +FIXME: make this a little smarter." + (let* ((s1 (icalendar-testsuite--trim str1)) + (s2 (icalendar-testsuite--trim str2)) + (result (compare-strings s1 0 nil s2 0 nil)) + (len (length str2))) + (if (numberp result) + (if (> result 0) + (concat "..." (substring str2 (- result 1) + (min len (+ (- result 1) 3))) "...") + (concat "..." (substring str2 (- (+ result 1)) + (min len (+ (- (+ result 1)) 3))) "...")) + t))) + +(defun icalendar-testsuite--run-internal-tests () + "Run icalendar-testsuite internal tests." + (assert (equal t (icalendar-testsuite--compare-strings " abcde" "abcde "))) + (assert + (string= "...def..." + (icalendar-testsuite--compare-strings "abcxe" "abcdefghijklmn"))) + (assert (string= "...xe..." + (icalendar-testsuite--compare-strings "abcde" "abcxe"))) + (assert (string= "...ddd..." + (icalendar-testsuite--compare-strings "abc" "abcdddddd"))) + (assert (string= "......" + (icalendar-testsuite--compare-strings "abcdefghij" "abc")))) + + +;; ====================================================================== ;; Test methods for functions ;; ====================================================================== (defun icalendar-testsuite--run-function-tests () @@ -260,7 +299,7 @@ END:VEVENT (assert (string= "subject" (cadr result))) ;; with time - (setq result (icalendar--convert-ordinary-to-ical + (setq result (icalendar--convert-ordinary-to-ical "&?" "&2010 2 15 12:34-23:45 s")) (assert (= 2 (length result))) (assert (string= (concat "\nDTSTART;VALUE=DATE-TIME:20100215T123400" @@ -269,7 +308,7 @@ END:VEVENT (assert (string= "s" (cadr result))) ;; with time, again -- test bug#5549 - (setq result (icalendar--convert-ordinary-to-ical + (setq result (icalendar--convert-ordinary-to-ical "x?" "x2010 2 15 0:34-1:45 s")) (assert (= 2 (length result))) (assert (string= (concat "\nDTSTART;VALUE=DATE-TIME:20100215T003400" @@ -312,7 +351,7 @@ END:VEVENT "Test method for `icalendar--convert-block-to-ical'." (let* ((calendar-date-style 'iso) result) - (setq result (icalendar--convert-block-to-ical + (setq result (icalendar--convert-block-to-ical "" "%%(diary-block 2004 7 19 2004 8 27) Sommerferien")) (assert (= 2 (length result))) (assert (string= (concat @@ -325,7 +364,7 @@ END:VEVENT "Test method for `icalendar--convert-cyclic-to-ical'." (let* ((calendar-date-style 'iso) result) - (setq result (icalendar--convert-block-to-ical + (setq result (icalendar--convert-block-to-ical "" "%%(diary-block 2004 7 19 2004 8 27) Sommerferien")) (assert (= 2 (length result))) (assert (string= (concat @@ -338,7 +377,7 @@ END:VEVENT "Test method for `icalendar--convert-anniversary-to-ical'." (let* ((calendar-date-style 'iso) result) - (setq result (icalendar--convert-anniversary-to-ical + (setq result (icalendar--convert-anniversary-to-ical "" "%%(diary-anniversary 1964 6 30) g")) (assert (= 2 (length result))) (assert (string= (concat @@ -386,6 +425,7 @@ END:VEVENT )) (defun icalendar-testsuite--test-parse-vtimezone () + "Test method for `icalendar--parse-vtimezone'." (let (vtimezone result) (setq vtimezone (icalendar-testsuite--get-ical-event "BEGIN:VTIMEZONE TZID:thename @@ -406,7 +446,8 @@ END:VTIMEZONE (setq result (icalendar--parse-vtimezone vtimezone)) (assert (string= "thename" (car result))) (message (cdr result)) - (assert (string= "STD-02:00DST-03:00,M3.5.0/03:00:00,M10.5.0/04:00:00" (cdr result))) + (assert (string= "STD-02:00DST-03:00,M3.5.0/03:00:00,M10.5.0/04:00:00" + (cdr result))) (setq vtimezone (icalendar-testsuite--get-ical-event "BEGIN:VTIMEZONE TZID:anothername BEGIN:STANDARD @@ -457,7 +498,7 @@ and ISO style input data must use english month names." (icalendar-testsuite--do-test-export input-iso expected-output))) (when input-european (let ((calendar-month-name-array - ["Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" + ["Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" "September" "Oktober" "November" "Dezember"]) (calendar-day-name-array ["Sonntag" "Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" @@ -511,12 +552,18 @@ END:VCALENDAR \\s-*$" nil t))) (error - "Export test failed! Input: `%s'\nFound:\n\n%s\n\nbut expected\n\n%s" + "Export test failed! Input: `%s'\nFound:\n\n%s\n\nbut expected\n\n%s\n%s" input (or (and (match-beginning 1) - (buffer-substring-no-properties (match-beginning 1) (match-end 1))) + (buffer-substring-no-properties (match-beginning 1) + (match-end 1))) + "<nil>") + (or expected-output "<nil>") + (icalendar-testsuite--compare-strings (or (and (match-beginning 1) + (buffer-substring-no-properties (match-beginning 1) + (match-end 1))) "<nil>") - (or expected-output "<nil>")))) + (or expected-output "<nil>"))))) (kill-buffer (find-buffer-visiting temp-file)) (delete-file temp-file))) @@ -571,11 +618,13 @@ Argument EXPECTED-OUTPUT expected diary string." (icalendar-import-buffer temp-file t t) (save-excursion (find-file temp-file) - (let ((result (buffer-substring-no-properties (point-min) (point-max)))) - (unless (string-match (concat "^\\s-*" expected-output "\\s-*$") - result) - (error "Import test failed! Found `%s'\nbut expected `%s'" result - expected-output))) + (let* ((result (buffer-substring-no-properties (point-min) (point-max))) + (difference + (icalendar-testsuite--compare-strings result + expected-output))) + (if (stringp difference) + (error "Import test failed! Found\n`%s'\nbut expected\n`%s'\n%s'" + result expected-output difference))) (kill-buffer (find-buffer-visiting temp-file)) (delete-file temp-file)))) @@ -626,9 +675,12 @@ Argument INPUT icalendar event string." (when (re-search-forward "\nUID:.*\n" nil t) (replace-match "\n")) (let ((cycled (buffer-substring-no-properties (point-min) (point-max)))) - (unless (string-equal org-input cycled) - (error "Import test failed! Found `%s'\nbut expected `%s'" cycled - org-input)))) + (let ((difference (icalendar-testsuite--compare-strings cycled + org-input))) + (if (stringp difference) + (error "Import test failed! Found\n`%s'\nbut expected\n`%s'\n%s'" + cycled org-input difference))) + )) ;; clean up -- Note this is done only if test is passed (kill-buffer (find-buffer-visiting temp-diary)) @@ -660,6 +712,7 @@ DTSTART;VALUE=DATE-TIME:20030919" "&9/19/2003 non-recurring allday") (icalendar-testsuite--test-import + ;; do not remove the trailing blank after "long"! "SUMMARY:long summary DTSTART;VALUE=DATE:20030919" @@ -678,9 +731,17 @@ DTSTART;VALUE=DATE:20040719 DTEND;VALUE=DATE:20040828 DTSTAMP:20031103T011641Z " - "&%%(and (diary-block 2004 7 19 2004 8 27)) Sommerferien" - "&%%(and (diary-block 19 7 2004 27 8 2004)) Sommerferien" - "&%%(and (diary-block 7 19 2004 8 27 2004)) Sommerferien") + "&%%(and (diary-block 2004 7 19 2004 8 27)) Sommerferien + Status: TENTATIVE + Class: PRIVATE +" + "&%%(and (diary-block 19 7 2004 27 8 2004)) Sommerferien + Status: TENTATIVE + Class: PRIVATE +" + "&%%(and (diary-block 7 19 2004 8 27 2004)) Sommerferien + Status: TENTATIVE + Class: PRIVATE") (icalendar-testsuite--test-import "UID @@ -702,9 +763,15 @@ DTSTAMP LAST-MODIFIED :20041118T013640Z " - "&2004/11/23 14:00-14:30 folded summary" - "&23/11/2004 14:00-14:30 folded summary" - "&11/23/2004 14:00-14:30 folded summary") + "&2004/11/23 14:00-14:30 folded summary + Status: TENTATIVE + Class: PRIVATE" + "&23/11/2004 14:00-14:30 folded summary + Status: TENTATIVE + Class: PRIVATE" + "&11/23/2004 14:00-14:30 folded summary + Status: TENTATIVE + Class: PRIVATE") (icalendar-testsuite--test-import "UID :6161a312-3902-11d9-b512-f764153bb28b @@ -723,9 +790,15 @@ DTEND DTSTAMP :20041118T013641Z " - "&2004/11/23 14:45-15:45 another example" - "&23/11/2004 14:45-15:45 another example" - "&11/23/2004 14:45-15:45 another example") + "&2004/11/23 14:45-15:45 another example + Status: TENTATIVE + Class: PRIVATE" + "&23/11/2004 14:45-15:45 another example + Status: TENTATIVE + Class: PRIVATE" + "&11/23/2004 14:45-15:45 another example + Status: TENTATIVE + Class: PRIVATE") (icalendar-testsuite--test-import "SUMMARY:rrule daily @@ -890,10 +963,55 @@ CLASS:PUBLIC SEQUENCE:1 CREATED:20041127T183329 " - "&%%(and (diary-cyclic 1 2001 12 21) (diary-block 2001 12 21 2001 12 29)) Urlaub" - "&%%(and (diary-cyclic 1 21 12 2001) (diary-block 21 12 2001 29 12 2001)) Urlaub" - "&%%(and (diary-cyclic 1 12 21 2001) (diary-block 12 21 2001 12 29 2001)) Urlaub") - ) + "&%%(and (diary-cyclic 1 2001 12 21) (diary-block 2001 12 21 2001 12 29)) Urlaub + Class: PUBLIC" + "&%%(and (diary-cyclic 1 21 12 2001) (diary-block 21 12 2001 29 12 2001)) Urlaub + Class: PUBLIC" + "&%%(and (diary-cyclic 1 12 21 2001) (diary-block 12 21 2001 12 29 2001)) Urlaub + Class: PUBLIC") + + ;;bug#6766 -- multiple byday values in a weekly rrule + (icalendar-testsuite--test-import +"CLASS:PUBLIC +DTEND;TZID=America/New_York:20100421T120000 +DTSTAMP:20100525T141214Z +DTSTART;TZID=America/New_York:20100421T113000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO,WE,TH,FR +SEQUENCE:1 +STATUS:CONFIRMED +SUMMARY:Scrum +TRANSP:OPAQUE +UID:8814e3f9-7482-408f-996c-3bfe486a1262 +END:VEVENT +BEGIN:VEVENT +CLASS:PUBLIC +DTSTAMP:20100525T141214Z +DTSTART;VALUE=DATE:20100422 +DTEND;VALUE=DATE:20100423 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=TU,TH +SEQUENCE:1 +SUMMARY:Tues + Thurs thinking +TRANSP:OPAQUE +UID:8814e3f9-7482-408f-996c-3bfe486a1263 +" +"&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 2010 4 21)) 11:30-12:00 Scrum + Status: CONFIRMED + Class: PUBLIC +&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 2010 4 22)) Tues + Thurs thinking + Class: PUBLIC" + +"&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 21 4 2010)) 11:30-12:00 Scrum + Status: CONFIRMED + Class: PUBLIC +&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 22 4 2010)) Tues + Thurs thinking + Class: PUBLIC" + +"&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 4 21 2010)) 11:30-12:00 Scrum + Status: CONFIRMED + Class: PUBLIC +&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 4 22 2010)) Tues + Thurs thinking + Class: PUBLIC") +) ;; ====================================================================== ;; Export tests @@ -1104,11 +1222,13 @@ END:VCALENDAR" "&9/5/2003 10:30-15:30 On-Site Interview Desc: 10:30am - Blah Location: Cccc - Organizer: MAILTO:aaaaaaa@aaaaaaa.com" + Organizer: MAILTO:aaaaaaa@aaaaaaa.com + Status: CONFIRMED" "&5/9/2003 10:30-15:30 On-Site Interview Desc: 10:30am - Blah Location: Cccc - Organizer: MAILTO:aaaaaaa@aaaaaaa.com") + Organizer: MAILTO:aaaaaaa@aaaaaaa.com + Status: CONFIRMED") ;; 2003-06-18 a (icalendar-testsuite--test-import @@ -1146,11 +1266,13 @@ END:VALARM" "&23/6/2003 11:00-12:00 Dress Rehearsal for XXXX-XXXX Desc: 753 Zeichen hier radiert Location: 555 or TN 555-5555 ID 5555 & NochWas (see below) - Organizer: MAILTO:xxx@xxxxx.com" + Organizer: MAILTO:xxx@xxxxx.com + Status: CONFIRMED" "&6/23/2003 11:00-12:00 Dress Rehearsal for XXXX-XXXX Desc: 753 Zeichen hier radiert Location: 555 or TN 555-5555 ID 5555 & NochWas (see below) - Organizer: MAILTO:xxx@xxxxx.com") + Organizer: MAILTO:xxx@xxxxx.com + Status: CONFIRMED") ;; 2003-06-18 b -- uses timezone (icalendar-testsuite--test-import @@ -1188,7 +1310,7 @@ ORGANIZER;CN=\"ABCD,TECHTRAINING \(A-Americas,exgen1)\":MAILTO:bbb@bbbbb.com LOCATION:123 or TN 123-1234 ID abcd & SonstWo (see below) DTEND;TZID=\"Mountain Time (US & Canada)\":20030623T100000 -DESCRIPTION:Viele Zeichen standen hier früher +DESCRIPTION:Viele Zeichen standen hier früher SEQUENCE:0 PRIORITY:5 CLASS: @@ -1211,12 +1333,12 @@ END:VEVENT END:VCALENDAR" nil "&23/6/2003 17:00-18:00 Updated: Dress Rehearsal for ABC01-15 - Desc: Viele Zeichen standen hier früher + Desc: Viele Zeichen standen hier früher Location: 123 or TN 123-1234 ID abcd & SonstWo (see below) Organizer: MAILTO:bbb@bbbbb.com Status: CONFIRMED" "&6/23/2003 17:00-18:00 Updated: Dress Rehearsal for ABC01-15 - Desc: Viele Zeichen standen hier früher + Desc: Viele Zeichen standen hier früher Location: 123 or TN 123-1234 ID abcd & SonstWo (see below) Organizer: MAILTO:bbb@bbbbb.com Status: CONFIRMED") @@ -1661,9 +1783,13 @@ DTSTAMP :20050128T011209Z" nil "&%%(and (diary-block 6 2 2005 6 2 2005)) Waitangi Day - Desc: abcdef" + Desc: abcdef + Status: CONFIRMED + Class: PRIVATE" "&%%(and (diary-block 2 6 2005 2 6 2005)) Waitangi Day - Desc: abcdef") + Desc: abcdef + Status: CONFIRMED + Class: PRIVATE") ;; 2005-03-01 lt (icalendar-testsuite--test-import diff --git a/test/indent/Makefile b/test/indent/Makefile new file mode 100644 index 00000000000..9e75f3dad57 --- /dev/null +++ b/test/indent/Makefile @@ -0,0 +1,15 @@ +RM=rm +EMACS=emacs + +clean: + -$(RM) *.test + +# TODO: +# - mark the places where the indentation is known to be incorrect, +# and allow either ignoring those errors or not. +%.test: % + -$(RM) $<.new + $(EMACS) --batch $< \ + --eval '(indent-region (point-min) (point-max) nil)' \ + --eval '(write-region (point-min) (point-max) "$<.new")' + diff -u -B $< $<.new diff --git a/test/indent/modula2.mod b/test/indent/modula2.mod new file mode 100644 index 00000000000..f8fbcb7f4e5 --- /dev/null +++ b/test/indent/modula2.mod @@ -0,0 +1,53 @@ +(* -*- mode: modula-2; m2-indent:3 -*- *) + +IMPLEMENTATION MODULE Indent ; + +(* This is (* a nested comment *) *) +// This is a single-line comment. + +FROM SYSTEM IMPORT ADR, TSIZE, SIZE, WORD ; + +CONST + c1 = 2; + +TYPE + t = POINTER TO ARRAY [0..10] OF LONGINT; + +VAR x: t; + y:LONGINT; + + +PROCEDURE f1 (f: File) : INTEGER ; + VAR + fd: FileDescriptor ; + PROCEDURE foo (a:CARDINAL) : INTEGER; + BEGIN + END foo; +BEGIN + IF f#Error + THEN + fd := GetIndice(FileInfo, f) ; + IF fd#NIL THEN + RETURN( fd^.unixfd ) + ELSE + CASE z OF + 1: do1(); + | 2: do2(); + toto(x); + | 3: ; + | 4: do4(); + ELSE do5(); + END ; (* CASE selection *) + + END + END ; + FormatError1('file %d has not been opened or is out of range\n', f) ; + RETURN( -1 ) +END f1 ; + + +BEGIN + init +FINALLY + done +END Indent. diff --git a/test/indent/octave.m b/test/indent/octave.m new file mode 100644 index 00000000000..768f3d85e01 --- /dev/null +++ b/test/indent/octave.m @@ -0,0 +1,2324 @@ +## -*- octave -*- + +function res = tcomp (fn) + %% res = tcomp (fn) + %% imports components and rearranges them. + + if nargin ~= 1 + print_usage() + end + + data = dlmread(fn, 3, 0); + + x = data(:,2:end); + y = 'hello'; + z = y'; + + cnty = repmat(x(:,1)(:), 10, 1); + + pop = x(:,1:10)(:); + ## Here and below, we test if the indentation aligns with a previous + ## fixindented line. This is important so as to make it easier for the + ## user to verride some indentation somewhere, and also because it + ## reflects the fact that the indentation decision is taken with a minimum + ## amount of work (i.e. in the present case, without having to walk back + ## until the `function' line). + bir = x(:,11:20)(:); # fixindent + dth = x(:,21:30)(:); + imig = x(:,31:40)(:); + dmig = x(:,41:50)(:); + gq = x(:,51:60)(:); + + yrs = repmat(2000:2009, 39, 1)(:); + + res = [yrs, cnty, pop, bir, dth, imig, dmig, gq]; + +endfunction + +## Copyright (C) 2005, 2006, 2007, 2008, 2009 S�ren Hauberg +## +## This file is part of Octave. +## +## Octave is free software; you can redistribute it and/or modify it +## under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 3 of the License, or (at +## your option) any later version. +## +## Octave 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 +## General Public License for more details. +## +## You should have received a copy of the GNU General Public License +## along with Octave; see the file COPYING. If not, see +## <http://www.gnu.org/licenses/>. + +## -*- texinfo -*- +## @deftypefn {Command} pkg @var{command} @var{pkg_name} +## @deftypefnx {Command} pkg @var{command} @var{option} @var{pkg_name} +## This command interacts with the package manager. Different actions will +## be taken depending on the value of @var{command}. +## +## @table @samp +## @item install +## Install named packages. For example, +## @example +## pkg install image-1.0.0.tar.gz +## @end example +## @noindent +## installs the package found in the file @file{image-1.0.0.tar.gz}. +## +## The @var{option} variable can contain options that affect the manner +## in which a package is installed. These options can be one or more of +## +## @table @code +## @item -nodeps +## The package manager will disable the dependency checking. That way it +## is possible to install a package even if it depends on another package +## that's not installed on the system. @strong{Use this option with care.} +## +## @item -noauto +## The package manager will not automatically load the installed package +## when starting Octave, even if the package requests that it is. +## +## @item -auto +## The package manager will automatically load the installed package when +## starting Octave, even if the package requests that it isn't. +## +## @item -local +## A local installation is forced, even if the user has system privileges. +## +## @item -global +## A global installation is forced, even if the user doesn't normally have +## system privileges +## +## @item -verbose +## The package manager will print the output of all of the commands that are +## performed. +## @end table +## +## @item uninstall +## Uninstall named packages. For example, +## @example +## pkg uninstall image +## @end example +## @noindent +## removes the @code{image} package from the system. If another installed +## package depends on the @code{image} package an error will be issued. +## The package can be uninstalled anyway by using the @code{-nodeps} option. +## @item load +## Add named packages to the path. After loading a package it is +## possible to use the functions provided by the package. For example, +## @example +## pkg load image +## @end example +## @noindent +## adds the @code{image} package to the path. It is possible to load all +## installed packages at once with the command +## @example +## pkg load all +## @end example +## @item unload +## Removes named packages from the path. After unloading a package it is +## no longer possible to use the functions provided by the package. +## This command behaves like the @code{load} command. +## @item list +## Show a list of the currently installed packages. By requesting one or two +## output argument it is possible to get a list of the currently installed +## packages. For example, +## @example +## installed_packages = pkg list; +## @end example +## @noindent +## returns a cell array containing a structure for each installed package. +## The command +## @example +## [@var{user_packages}, @var{system_packages}] = pkg list +## @end example +## @noindent +## splits the list of installed packages into those who are installed by +## the current user, and those installed by the system administrator. +## @item describe +## Show a short description of the named installed packages, with the option +## '-verbose' also list functions provided by the package, e.g.: +## @example +## pkg describe -verbose all +## @end example +## @noindent +## will describe all installed packages and the functions they provide. +## If one output is requested a cell of structure containing the +## description and list of functions of each package is returned as +## output rather than printed on screen: +## @example +## desc = pkg ("describe", "secs1d", "image") +## @end example +## @noindent +## If any of the requested packages is not installed, pkg returns an +## error, unless a second output is requested: +## @example +## [ desc, flag] = pkg ("describe", "secs1d", "image") +## @end example +## @noindent +## @var{flag} will take one of the values "Not installed", "Loaded" or +## "Not loaded" for each of the named packages. +## @item prefix +## Set the installation prefix directory. For example, +## @example +## pkg prefix ~/my_octave_packages +## @end example +## @noindent +## sets the installation prefix to @file{~/my_octave_packages}. +## Packages will be installed in this directory. +## +## It is possible to get the current installation prefix by requesting an +## output argument. For example, +## @example +## p = pkg prefix +## @end example +## +## The location in which to install the architecture dependent files can be +## independent specified with an addition argument. For example +## +## @example +## pkg prefix ~/my_octave_packages ~/my_arch_dep_pkgs +## @end example +## @item local_list +## Set the file in which to look for information on the locally +## installed packages. Locally installed packages are those that are +## typically available only to the current user. For example +## @example +## pkg local_list ~/.octave_packages +## @end example +## It is possible to get the current value of local_list with the following +## @example +## pkg local_list +## @end example +## @item global_list +## Set the file in which to look for, for information on the globally +## installed packages. Globally installed packages are those that are +## typically available to all users. For example +## @example +## pkg global_list /usr/share/octave/octave_packages +## @end example +## It is possible to get the current value of global_list with the following +## @example +## pkg global_list +## @end example +## @item rebuild +## Rebuilds the package database from the installed directories. This can +## be used in cases where for some reason the package database is corrupted. +## It can also take the @code{-auto} and @code{-noauto} options to allow the +## autoloading state of a package to be changed. For example +## +## @example +## pkg rebuild -noauto image +## @end example +## +## will remove the autoloading status of the image package. +## @item build +## Builds a binary form of a package or packages. The binary file produced +## will itself be an Octave package that can be installed normally with +## @code{pkg}. The form of the command to build a binary package is +## +## @example +## pkg build builddir image-1.0.0.tar.gz @dots{} +## @end example +## +## @noindent +## where @code{builddir} is the name of a directory where the temporary +## installation will be produced and the binary packages will be found. +## The options @code{-verbose} and @code{-nodeps} are respected, while +## the other options are ignored. +## @end table +## @end deftypefn + +function [local_packages, global_packages] = pkg (varargin) + ## Installation prefix (FIXME: what should these be on windows?) + persistent user_prefix = false; + persistent prefix = -1; + persistent archprefix = -1; + persistent local_list = tilde_expand (fullfile ("~", ".octave_packages")); + persistent global_list = fullfile (OCTAVE_HOME (), "share", "octave", + "octave_packages"); + mlock (); + + global_install = issuperuser (); + + if (prefix == -1) + if (global_install) + prefix = fullfile (OCTAVE_HOME (), "share", "octave", "packages"); + archprefix = fullfile (octave_config_info ("libexecdir"), + "octave", "packages"); + else + prefix = fullfile ("~", "octave"); + archprefix = prefix; + endif + prefix = tilde_expand (prefix); + archprefix = tilde_expand (archprefix); + endif + + available_actions = {"list", "install", "uninstall", "load", ... + "unload", "prefix", "local_list", ... + "global_list", "rebuild", "build","describe"}; + ## Handle input + if (length (varargin) == 0 || ! iscellstr (varargin)) + print_usage (); + endif + files = {}; + deps = true; + auto = 0; + action = "none"; + verbose = false; + for i = 1:length (varargin) + switch (varargin{i}) + case "-nodeps" + deps = false; + case "-noauto" + auto = -1; + case "-auto" + auto = 1; + case "-verbose" + verbose = true; + case "-local" + global_install = false; + if (! user_prefix) + prefix = tilde_expand (fullfile ("~", "octave")); + archprefix = prefix; + endif + case "-global" + global_install = true; + if (! user_prefix) + prefix = fullfile (OCTAVE_HOME (), "share", "octave", "packages"); + archprefix = fullfile (octave_config_info ("libexecdir"), + "octave", "packages"); + endif + case available_actions + if (strcmp (action, "none")) + action = varargin{i}; + else + error ("more than one action specified"); + endif + otherwise + files{end+1} = varargin{i}; + endswitch + endfor + + ## Take action + switch (action) + case "list" + if (nargout == 0) + installed_packages (local_list, global_list); + elseif (nargout == 1) + local_packages = installed_packages (local_list, global_list); + elseif (nargout == 2) + [local_packages, global_packages] = installed_packages (local_list, + global_list); + else + error ("too many output arguments requested"); + endif + + case "install" + if (length (files) == 0) + error ("you must specify at least one filename when calling 'pkg install'"); + endif + install (files, deps, auto, prefix, archprefix, verbose, local_list, + global_list, global_install); + + case "uninstall" + if (length (files) == 0) + error ("you must specify at least one package when calling 'pkg uninstall'"); + endif + uninstall (files, deps, verbose, local_list, + global_list, global_install); + + case "load" + if (length (files) == 0) + error ("you must specify at least one package, 'all' or 'auto' when calling 'pkg load'"); + endif + load_packages (files, deps, local_list, global_list); + + case "unload" + if (length (files) == 0) + error ("you must specify at least one package or 'all' when calling 'pkg unload'"); + endif + unload_packages (files, deps, local_list, global_list); + + case "prefix" + if (length (files) == 0 && nargout == 0) + printf ("Installation prefix: %s\n", prefix); + printf ("Architecture dependent prefix: %s\n", archprefix); + elseif (length (files) == 0 && nargout >= 1) + local_packages = prefix; + global_packages = archprefix; + elseif (length (files) >= 1 && nargout <= 2 && ischar (files{1})) + prefix = files{1}; + prefix = absolute_pathname (prefix); + local_packages = prefix; + user_prefix = true; + if (length (files) >= 2 && ischar (files{2})) + archprefix = files{2}; + try + archprefix = absolute_pathname (archprefix); + catch + mkdir (archprefix); + warning ("creating the directory %s\n", archprefix); + archprefix = absolute_pathname (archprefix); + end_try_catch + global_packages = archprefix; + endif + else + error ("you must specify a prefix directory, or request an output argument"); + endif + + case "local_list" + if (length (files) == 0 && nargout == 0) + disp (local_list); + elseif (length (files) == 0 && nargout == 1) + local_packages = local_list; + elseif (length (files) == 1 && nargout == 0 && ischar (files{1})) + try + local_list = absolute_pathname (files{1}); + catch + ## Force file to be created + fclose (fopen (files{1}, "wt")); + local_list = absolute_pathname (files{1}); + end_try_catch + else + error ("you must specify a local_list file, or request an output argument"); + endif + + case "global_list" + if (length (files) == 0 && nargout == 0) + disp(global_list); + elseif (length (files) == 0 && nargout == 1) + local_packages = global_list; + elseif (length (files) == 1 && nargout == 0 && ischar (files{1})) + try + global_list = absolute_pathname (files{1}); + catch + ## Force file to be created + fclose (fopen (files{1}, "wt")); + global_list = absolute_pathname (files{1}); + end_try_catch + else + error ("you must specify a global_list file, or request an output argument"); + endif + + case "rebuild" + if (global_install) + global_packages = rebuild (prefix, archprefix, global_list, files, + auto, verbose); + global_packages = save_order (global_packages); + save (global_list, "global_packages"); + if (nargout > 0) + local_packages = global_packages; + endif + else + local_packages = rebuild (prefix, archprefix, local_list, files, auto, + verbose); + local_packages = save_order (local_packages); + save (local_list, "local_packages"); + if (nargout == 0) + clear ("local_packages"); + endif + endif + + case "build" + if (length (files) < 2) + error ("you must specify at least the build directory and one filename\nwhen calling 'pkg build'"); + endif + build (files, deps, auto, verbose); + + case "describe" + if (length (files) == 0) + error ("you must specify at least one package or 'all' when calling 'pkg describe'"); + endif + ## FIXME: the name of the output variables is inconsistent + ## with their content + switch (nargout) + case 0 + describe (files, verbose, local_list, global_list); + case 1 + pkg_desc_list = describe (files, verbose, local_list, ... + global_list); + local_packages = pkg_desc_list; + case 2 + [pkg_desc_list, flag] = describe (files, verbose, local_list, ... + global_list); + local_packages = pkg_desc_list; + global_packages = flag; + otherwise + error ("you can request at most two outputs when calling 'pkg describe'"); + endswitch + + otherwise + error ("you must specify a valid action for 'pkg'. See 'help pkg' for details"); + endswitch +endfunction + +function descriptions = rebuild (prefix, archprefix, list, files, auto, verbose) + if (isempty (files)) + [dirlist, err, msg] = readdir (prefix); + if (err) + error ("couldn't read directory %s: %s", prefix, msg); + endif + ## the two first entries of dirlist are "." and ".." + dirlist([1,2]) = []; + else + old_descriptions = installed_packages (list, list); + wd = pwd (); + unwind_protect + cd (prefix); + dirlist = glob (cellfun(@(x) cstrcat(x, '-*'), files, 'UniformOutput', 0)); + unwind_protect_cleanup + cd (wd); + end_unwind_protect + endif + descriptions = {}; + for k = 1:length (dirlist) + descfile = fullfile (prefix, dirlist{k}, "packinfo", "DESCRIPTION"); + if (verbose) + printf ("recreating package description from %s\n", dirlist{k}); + endif + if (exist (descfile, "file")) + desc = get_description (descfile); + desc.dir = fullfile (prefix, dirlist{k}); + desc.archprefix = fullfile (archprefix, cstrcat (desc.name, "-", + desc.version)); + if (auto != 0) + if (exist (fullfile (desc.dir, "packinfo", ".autoload"), "file")) + unlink (fullfile (desc.dir, "packinfo", ".autoload")); + endif + if (auto < 0) + desc.autoload = 0; + elseif (auto > 0) + desc.autoload = 1; + fclose (fopen (fullfile (desc.dir, "packinfo", ".autoload"), "wt")); + endif + else + if (exist (fullfile (desc.dir, "packinfo", ".autoload"), "file")) + desc.autoload = 1; + else + desc.autoload = 0; + endif + endif + descriptions{end + 1} = desc; + elseif (verbose) + warning ("directory %s is not a valid package", dirlist{k}); + endif + endfor + + if (! isempty (files)) + ## We are rebuilding for a particular package(s) so we should take + ## care to keep the other untouched packages in the descriptions + descriptions = {descriptions{:}, old_descriptions{:}}; + + dup = []; + for i = 1:length (descriptions) + if (find (dup, i)) + continue; + endif + for j = (i+1):length (descriptions) + if (find (dup, j)) + continue; + endif + if (strcmp (descriptions{i}.name, descriptions{j}.name)) + dup = [dup, j]; + endif + endfor + endfor + if (! isempty (dup)) + descriptions (dup) = []; + endif + endif +endfunction + +function build (files, handle_deps, autoload, verbose) + if (length (files) < 1) + error ("insufficient number of files"); + endif + builddir = files{1}; + if (! exist (builddir, "dir")) + warning ("creating build directory %s", builddir); + [status, msg] = mkdir (builddir); + if (status != 1) + error ("could not create installation directory: %s", msg); + endif + endif + builddir = absolute_pathname (builddir); + installdir = fullfile (builddir, "install"); + if (! exist (installdir, "dir")) + [status, msg] = mkdir (installdir); + if (status != 1) + error ("could not create installation directory: %s", msg); + endif + endif + files(1) = []; + buildlist = fullfile (builddir, "octave_packages"); + install (files, handle_deps, autoload, installdir, installdir, verbose, + buildlist, "", false); + unwind_protect + repackage (builddir, buildlist); + unwind_protect_cleanup + unload_packages ({"all"}, handle_deps, buildlist, ""); + if (exist (installdir, "dir")) + rm_rf (installdir); + endif + if (exist (buildlist, "file")) + unlink (buildlist); + endif + end_unwind_protect +endfunction + +function install (files, handle_deps, autoload, prefix, archprefix, verbose, + local_list, global_list, global_install) + + ## Check that the directory in prefix exist. If it doesn't: create it! + if (! exist (prefix, "dir")) + warning ("creating installation directory %s", prefix); + [status, msg] = mkdir (prefix); + if (status != 1) + error ("could not create installation directory: %s", msg); + endif + endif + + ## Get the list of installed packages. + [local_packages, global_packages] = installed_packages (local_list, + global_list); + + installed_pkgs_lst = {local_packages{:}, global_packages{:}}; + + if (global_install) + packages = global_packages; + else + packages = local_packages; + endif + + ## Uncompress the packages and read the DESCRIPTION files. + tmpdirs = packdirs = descriptions = {}; + try + ## Warn about non existent files. + for i = 1:length (files) + if (isempty (glob(files{i}))) + warning ("file %s does not exist", files{i}); + endif + endfor + + ## Unpack the package files and read the DESCRIPTION files. + files = glob (files); + packages_to_uninstall = []; + for i = 1:length (files) + tgz = files{i}; + + if (exist (tgz, "file")) + ## Create a temporary directory. + tmpdir = tmpnam (); + tmpdirs{end+1} = tmpdir; + if (verbose) + printf ("mkdir (%s)\n", tmpdir); + endif + [status, msg] = mkdir (tmpdir); + if (status != 1) + error ("couldn't create temporary directory: %s", msg); + endif + + ## Uncompress the package. + if (verbose) + printf ("untar (%s, %s)\n", tgz, tmpdir); + endif + untar (tgz, tmpdir); + + ## Get the name of the directories produced by tar. + [dirlist, err, msg] = readdir (tmpdir); + if (err) + error ("couldn't read directory produced by tar: %s", msg); + endif + + if (length (dirlist) > 3) + error ("bundles of packages are not allowed") + endif + endif + + ## The filename pointed to an uncompressed package to begin with. + if (exist (tgz, "dir")) + dirlist = {".", "..", tgz}; + endif + + if (exist (tgz, "file") || exist (tgz, "dir")) + ## The two first entries of dirlist are "." and "..". + if (exist (tgz, "file")) + packdir = fullfile (tmpdir, dirlist{3}); + else + packdir = fullfile (pwd(), dirlist{3}); + endif + packdirs{end+1} = packdir; + + ## Make sure the package contains necessary files. + verify_directory (packdir); + + ## Read the DESCRIPTION file. + filename = fullfile (packdir, "DESCRIPTION"); + desc = get_description (filename); + + ## Verify that package name corresponds with filename. + [dummy, nm] = fileparts (tgz); + if ((length (nm) >= length (desc.name)) + && ! strcmp (desc.name, nm(1:length(desc.name)))) + error ("package name '%s' doesn't correspond to its filename '%s'", + desc.name, nm); + endif + + ## Set default installation directory. + desc.dir = fullfile (prefix, cstrcat (desc.name, "-", desc.version)); + + ## Set default architectire dependent installation directory. + desc.archprefix = fullfile (archprefix, cstrcat (desc.name, "-", + desc.version)); + + ## Save desc. + descriptions{end+1} = desc; + + ## Are any of the new packages already installed? + ## If so we'll remove the old version. + for j = 1:length (packages) + if (strcmp (packages{j}.name, desc.name)) + packages_to_uninstall(end+1) = j; + endif + endfor + endif + endfor + catch + ## Something went wrong, delete tmpdirs. + for i = 1:length (tmpdirs) + rm_rf (tmpdirs{i}); + endfor + rethrow (lasterror ()); + end_try_catch + + ## Check dependencies. + if (handle_deps) + ok = true; + error_text = ""; + for i = 1:length (descriptions) + desc = descriptions{i}; + idx2 = complement (i, 1:length(descriptions)); + if (global_install) + ## Global installation is not allowed to have dependencies on locally + ## installed packages. + idx1 = complement (packages_to_uninstall, + 1:length(global_packages)); + pseudo_installed_packages = {global_packages{idx1}, ... + descriptions{idx2}}; + else + idx1 = complement (packages_to_uninstall, + 1:length(local_packages)); + pseudo_installed_packages = {local_packages{idx1}, ... + global_packages{:}, ... + descriptions{idx2}}; + endif + bad_deps = get_unsatisfied_deps (desc, pseudo_installed_packages); + ## Are there any unsatisfied dependencies? + if (! isempty (bad_deps)) + ok = false; + for i = 1:length (bad_deps) + dep = bad_deps{i}; + error_text = cstrcat (error_text, " ", desc.name, " needs ", + dep.package, " ", dep.operator, " ", + dep.version, "\n"); + endfor + endif + endfor + + ## Did we find any unsatisfied dependencies? + if (! ok) + error ("the following dependencies where unsatisfied:\n %s", error_text); + endif + endif + + ## Prepare each package for installation. + try + for i = 1:length (descriptions) + desc = descriptions{i}; + pdir = packdirs{i}; + prepare_installation (desc, pdir); + configure_make (desc, pdir, verbose); + endfor + catch + ## Something went wrong, delete tmpdirs. + for i = 1:length (tmpdirs) + rm_rf (tmpdirs{i}); + endfor + rethrow (lasterror ()); + end_try_catch + + ## Uninstall the packages that will be replaced. + try + for i = packages_to_uninstall + if (global_install) + uninstall ({global_packages{i}.name}, false, verbose, local_list, + global_list, global_install); + else + uninstall ({local_packages{i}.name}, false, verbose, local_list, + global_list, global_install); + endif + endfor + catch + ## Something went wrong, delete tmpdirs. + for i = 1:length (tmpdirs) + rm_rf (tmpdirs{i}); + endfor + rethrow (lasterror ()); + end_try_catch + + ## Install each package. + try + for i = 1:length (descriptions) + desc = descriptions{i}; + pdir = packdirs{i}; + copy_files (desc, pdir, global_install); + create_pkgadddel (desc, pdir, "PKG_ADD", global_install); + create_pkgadddel (desc, pdir, "PKG_DEL", global_install); + finish_installation (desc, pdir, global_install); + generate_lookfor_cache (desc); + endfor + catch + ## Something went wrong, delete tmpdirs. + for i = 1:length (tmpdirs) + rm_rf (tmpdirs{i}); + endfor + for i = 1:length (descriptions) + rm_rf (descriptions{i}.dir); + rm_rf (getarchdir (descriptions{i})); + endfor + rethrow (lasterror ()); + end_try_catch + + ## Check if the installed directory is empty. If it is remove it + ## from the list. + for i = length (descriptions):-1:1 + if (dirempty (descriptions{i}.dir, {"packinfo", "doc"}) && + dirempty (getarchdir (descriptions{i}))) + warning ("package %s is empty\n", descriptions{i}.name); + rm_rf (descriptions{i}.dir); + rm_rf (getarchdir (descriptions{i})); + descriptions(i) = []; + endif + endfor + + ## If the package requested that it is autoloaded, or the installer + ## requested that it is, then mark the package as autoloaded. + for i = length (descriptions):-1:1 + if (autoload > 0 || (autoload == 0 && isautoload (descriptions(i)))) + fclose (fopen (fullfile (descriptions{i}.dir, "packinfo", + ".autoload"), "wt")); + descriptions{i}.autoload = 1; + endif + endfor + + ## Add the packages to the package list. + try + if (global_install) + idx = complement (packages_to_uninstall, 1:length(global_packages)); + global_packages = save_order ({global_packages{idx}, descriptions{:}}); + save (global_list, "global_packages"); + installed_pkgs_lst = {local_packages{:}, global_packages{:}}; + else + idx = complement (packages_to_uninstall, 1:length(local_packages)); + local_packages = save_order ({local_packages{idx}, descriptions{:}}); + save (local_list, "local_packages"); + installed_pkgs_lst = {local_packages{:}, global_packages{:}}; + endif + catch + ## Something went wrong, delete tmpdirs. + for i = 1:length (tmpdirs) + rm_rf (tmpdirs{i}); + endfor + for i = 1:length (descriptions) + rm_rf (descriptions{i}.dir); + endfor + if (global_install) + printf ("error: couldn't append to %s\n", global_list); + else + printf ("error: couldn't append to %s\n", local_list); + endif + rethrow (lasterror ()); + end_try_catch + + ## All is well, let's clean up. + for i = 1:length (tmpdirs) + [status, msg] = rm_rf (tmpdirs{i}); + if (status != 1) + warning ("couldn't clean up after my self: %s\n", msg); + endif + endfor + + ## Add the newly installed packages to the path, so the user + ## can begin using them. Only load them if they are marked autoload. + if (length (descriptions) > 0) + idx = []; + for i = 1:length (descriptions) + if (isautoload (descriptions(i))) + nm = descriptions{i}.name; + for j = 1:length (installed_pkgs_lst) + if (strcmp (nm, installed_pkgs_lst{j}.name)) + idx (end + 1) = j; + break; + endif + endfor + endif + endfor + load_packages_and_dependencies (idx, handle_deps, installed_pkgs_lst, + global_install); + endif +endfunction + +function uninstall (pkgnames, handle_deps, verbose, local_list, + global_list, global_install) + ## Get the list of installed packages. + [local_packages, global_packages] = installed_packages(local_list, + global_list); + if (global_install) + installed_pkgs_lst = {local_packages{:}, global_packages{:}}; + else + installed_pkgs_lst = local_packages; + endif + + num_packages = length (installed_pkgs_lst); + delete_idx = []; + for i = 1:num_packages + cur_name = installed_pkgs_lst{i}.name; + if (any (strcmp (cur_name, pkgnames))) + delete_idx(end+1) = i; + endif + endfor + + ## Are all the packages that should be uninstalled already installed? + if (length (delete_idx) != length (pkgnames)) + if (global_install) + ## Try again for a locally installed package. + installed_pkgs_lst = local_packages; + + num_packages = length (installed_pkgs_lst); + delete_idx = []; + for i = 1:num_packages + cur_name = installed_pkgs_lst{i}.name; + if (any (strcmp (cur_name, pkgnames))) + delete_idx(end+1) = i; + endif + endfor + if (length (delete_idx) != length (pkgnames)) + ## FIXME: We should have a better error message. + warning ("some of the packages you want to uninstall are not installed"); + endif + else + ## FIXME: We should have a better error message. + warning ("some of the packages you want to uninstall are not installed"); + endif + endif + + ## Compute the packages that will remain installed. + idx = complement (delete_idx, 1:num_packages); + remaining_packages = {installed_pkgs_lst{idx}}; + + ## Check dependencies. + if (handle_deps) + error_text = ""; + for i = 1:length (remaining_packages) + desc = remaining_packages{i}; + bad_deps = get_unsatisfied_deps (desc, remaining_packages); + + ## Will the uninstallation break any dependencies? + if (! isempty (bad_deps)) + for i = 1:length (bad_deps) + dep = bad_deps{i}; + error_text = cstrcat (error_text, " ", desc.name, " needs ", + dep.package, " ", dep.operator, " ", + dep.version, "\n"); + endfor + endif + endfor + + if (! isempty (error_text)) + error ("the following dependencies where unsatisfied:\n %s", error_text); + endif + endif + + ## Delete the directories containing the packages. + for i = delete_idx + desc = installed_pkgs_lst{i}; + ## If an 'on_uninstall.m' exist, call it! + if (exist (fullfile (desc.dir, "packinfo", "on_uninstall.m"), "file")) + wd = pwd (); + cd (fullfile (desc.dir, "packinfo")); + on_uninstall (desc); + cd (wd); + endif + ## Do the actual deletion. + if (desc.loaded) + rmpath (desc.dir); + if (exist (getarchdir (desc))) + rmpath (getarchdir (desc)); + endif + endif + if (exist (desc.dir, "dir")) + [status, msg] = rm_rf (desc.dir); + if (status != 1) + error ("couldn't delete directory %s: %s", desc.dir, msg); + endif + [status, msg] = rm_rf (getarchdir (desc)); + if (status != 1) + error ("couldn't delete directory %s: %s", getarchdir (desc), msg); + endif + if (dirempty (desc.archprefix)) + rm_rf (desc.archprefix); + endif + else + warning ("directory %s previously lost", desc.dir); + endif + endfor + + ## Write a new ~/.octave_packages. + if (global_install) + if (length (remaining_packages) == 0) + unlink (global_list); + else + global_packages = save_order (remaining_packages); + save (global_list, "global_packages"); + endif + else + if (length (remaining_packages) == 0) + unlink (local_list); + else + local_packages = save_order (remaining_packages); + save (local_list, "local_packages"); + endif + endif + +endfunction + +function [pkg_desc_list, flag] = describe (pkgnames, verbose, + local_list, global_list) + + ## Get the list of installed packages. + installed_pkgs_lst = installed_packages(local_list, global_list); + num_packages = length (installed_pkgs_lst); + + + describe_all = false; + if (any (strcmp ("all", pkgnames))) + describe_all = true; + flag(1:num_packages) = {"Not Loaded"}; + num_pkgnames = num_packages; + else + num_pkgnames = length (pkgnames); + flag(1:num_pkgnames) = {"Not installed"}; + endif + + for i = 1:num_packages + curr_name = installed_pkgs_lst{i}.name; + if (describe_all) + name_pos = i; + else + name_pos = find(strcmp (curr_name, pkgnames)); + endif + + if (! isempty (name_pos)) + if (installed_pkgs_lst{i}.loaded) + flag{name_pos} = "Loaded"; + else + flag{name_pos} = "Not loaded"; + endif + + pkg_desc_list{name_pos}.name = installed_pkgs_lst{i}.name; + pkg_desc_list{name_pos}.version = installed_pkgs_lst{i}.version; + pkg_desc_list{name_pos}.description = installed_pkgs_lst{i}.description; + pkg_desc_list{name_pos}.provides = parse_pkg_idx (installed_pkgs_lst{i}.dir); + + endif + endfor + + non_inst = find (strcmp (flag, "Not installed")); + if (! isempty (non_inst)) + if (nargout < 2) + non_inst_str = sprintf (" %s ", pkgnames{non_inst}); + error ("some packages are not installed: %s", non_inst_str); + else + pkg_desc_list{non_inst} = struct ("name", {}, "description", + {}, "provides", {}); + endif + endif + + if (nargout == 0) + for i = 1:num_pkgnames + print_package_description (pkg_desc_list{i}.name, + pkg_desc_list{i}.version, + pkg_desc_list{i}.provides, + pkg_desc_list{i}.description, + flag{i}, verbose); + endfor + endif + +endfunction + +## AUXILIARY FUNCTIONS + +## Read an INDEX file. +function [pkg_idx_struct] = parse_pkg_idx (packdir) + + index_file = fullfile (packdir, "packinfo", "INDEX"); + + if (! exist (index_file, "file")) + error ("could not find any INDEX file in directory %s, try 'pkg rebuild all' to generate missing INDEX files", packdir); + endif + + + [fid, msg] = fopen (index_file, "r"); + if (fid == -1) + error ("the INDEX file %s could not be read: %s", + index_file, msg); + endif + + cat_num = 1; + pkg_idx_struct{1}.category = "Uncategorized"; + pkg_idx_struct{1}.functions = {}; + + line = fgetl (fid); + while (isempty (strfind (line, ">>")) && ! feof (fid)) + line = fgetl (fid); + endwhile + + while (! feof (fid) || line != -1) + if (! any (! isspace (line)) || line(1) == "#" || any (line == "=")) + ## Comments, blank lines or comments about unimplemented + ## functions: do nothing + ## FIXME: probably comments and pointers to external functions + ## could be treated better when printing to screen? + elseif (! isempty (strfind (line, ">>"))) + ## Skip package name and description as they are in DESCRIPTION + ## already. + elseif (! isspace (line(1))) + ## Category. + if (! isempty (pkg_idx_struct{cat_num}.functions)) + pkg_idx_struct{++cat_num}.functions = {}; + endif + pkg_idx_struct{cat_num}.category = deblank (line); + else + ## Function names. + while (any (! isspace (line))) + [fun_name, line] = strtok (line); + pkg_idx_struct{cat_num}.functions{end+1} = deblank (fun_name); + endwhile + endif + line = fgetl (fid); + endwhile + fclose (fid); +endfunction + +function print_package_description (pkg_name, pkg_ver, pkg_idx_struct, + pkg_desc, status, verbose) + + printf ("---\nPackage name:\n\t%s\n", pkg_name); + printf ("Version:\n\t%s\n", pkg_ver); + printf ("Short description:\n\t%s\n", pkg_desc); + printf ("Status:\n\t%s\n", status); + if (verbose) + printf ("---\nProvides:\n"); + for i = 1:length(pkg_idx_struct) + if (! isempty (pkg_idx_struct{i}.functions)) + printf ("%s\n", pkg_idx_struct{i}.category); + for j = 1:length(pkg_idx_struct{i}.functions) + printf ("\t%s\n", pkg_idx_struct{i}.functions{j}); + endfor + endif + endfor + endif + +endfunction + + +function pth = absolute_pathname (pth) + [status, msg, msgid] = fileattrib (pth); + if (status != 1) + error ("could not find the file or path %s", pth); + else + pth = msg.Name; + endif +endfunction + +function repackage (builddir, buildlist) + packages = installed_packages (buildlist, buildlist); + + wd = pwd(); + for i = 1 : length(packages) + pack = packages{i}; + unwind_protect + cd (builddir); + mkdir (pack.name); + mkdir (fullfile (pack.name, "inst")); + copyfile (fullfile (pack.dir, "*"), fullfile (pack.name, "inst")); + movefile (fullfile (pack.name, "inst","packinfo", "*"), pack.name); + if (exist (fullfile (pack.name, "inst","packinfo", ".autoload"), "file")) + unlink (fullfile (pack.name, "inst","packinfo", ".autoload")); + endif + rmdir (fullfile (pack.name, "inst", "packinfo")); + if (exist (fullfile (pack.name, "inst", "doc"), "dir")) + movefile (fullfile (pack.name, "inst", "doc"), pack.name); + endif + if (exist (fullfile (pack.name, "inst", "bin"), "dir")) + movefile (fullfile (pack.name, "inst", "bin"), pack.name); + endif + archdir = fullfile (pack.archprefix, cstrcat (pack.name, "-", + pack.version), getarch ()); + if (exist (archdir, "dir")) + if (exist (fullfile (pack.name, "inst", "PKG_ADD"), "file")) + unlink (fullfile (pack.name, "inst", "PKG_ADD")); + endif + if (exist (fullfile (pack.name, "inst", "PKG_DEL"), "file")) + unlink (fullfile (pack.name, "inst", "PKG_DEL")); + endif + if (exist (fullfile (archdir, "PKG_ADD"), "file")) + movefile (fullfile (archdir, "PKG_ADD"), + fullfile (pack.name, "PKG_ADD")); + endif + if (exist (fullfile (archdir, "PKG_DEL"), "file")) + movefile (fullfile (archdir, "PKG_DEL"), + fullfile (pack.name, "PKG_DEL")); + endif + else + if (exist (fullfile (pack.name, "inst", "PKG_ADD"), "file")) + movefile (fullfile (pack.name, "inst", "PKG_ADD"), + fullfile (pack.name, "PKG_ADD")); + endif + if (exist (fullfile (pack.name, "inst", "PKG_DEL"), "file")) + movefile (fullfile (pack.name, "inst", "PKG_DEL"), + fullfile (pack.name, "PKG_DEL")); + endif + endif + tfile = cstrcat (pack.name, "-", pack.version, ".tar"); + tar (tfile, pack.name); + try + gzip (tfile); + unlink (tfile); + catch + warning ("failed to compress %s", tfile); + end_try_catch + unwind_protect_cleanup + if (exist (pack.name, "dir")) + rm_rf (pack.name); + endif + cd (wd); + end_unwind_protect + endfor +endfunction + +function auto = isautoload (desc) + auto = false; + if (isfield (desc{1}, "autoload")) + a = desc{1}.autoload; + if ((isnumeric (a) && a > 0) + || (ischar (a) && (strcmpi (a, "true") + || strcmpi (a, "on") + || strcmpi (a, "yes") + || strcmpi (a, "1")))) + auto = true; + endif + endif +endfunction + +function prepare_installation (desc, packdir) + ## Is there a pre_install to call? + if (exist (fullfile (packdir, "pre_install.m"), "file")) + wd = pwd (); + try + cd (packdir); + pre_install (desc); + cd (wd); + catch + cd (wd); + rethrow (lasterror ()); + end_try_catch + endif + + ## If the directory "inst" doesn't exist, we create it. + inst_dir = fullfile (packdir, "inst"); + if (! exist (inst_dir, "dir")) + [status, msg] = mkdir (inst_dir); + if (status != 1) + rm_rf (desc.dir); + error ("the 'inst' directory did not exist and could not be created: %s", + msg); + endif + endif +endfunction + +function configure_make (desc, packdir, verbose) + ## Perform ./configure, make, make install in "src". + if (exist (fullfile (packdir, "src"), "dir")) + src = fullfile (packdir, "src"); + ## Configure. + if (exist (fullfile (src, "configure"), "file")) + flags = ""; + if (isempty (getenv ("CC"))) + flags = cstrcat (flags, " CC=\"", octave_config_info ("CC"), "\""); + endif + if (isempty (getenv ("CXX"))) + flags = cstrcat (flags, " CXX=\"", octave_config_info ("CXX"), "\""); + endif + if (isempty (getenv ("AR"))) + flags = cstrcat (flags, " AR=\"", octave_config_info ("AR"), "\""); + endif + if (isempty (getenv ("RANLIB"))) + flags = cstrcat (flags, " RANLIB=\"", octave_config_info ("RANLIB"), "\""); + endif + [status, output] = shell (strcat ("cd '", src, "'; ./configure --prefix=\"", + desc.dir, "\"", flags)); + if (status != 0) + rm_rf (desc.dir); + error ("the configure script returned the following error: %s", output); + elseif (verbose) + printf("%s", output); + endif + + endif + + ## Make. + if (exist (fullfile (src, "Makefile"), "file")) + [status, output] = shell (cstrcat ("export INSTALLDIR=\"", desc.dir, + "\"; make -C '", src, "'")); + if (status != 0) + rm_rf (desc.dir); + error ("'make' returned the following error: %s", output); + elseif (verbose) + printf("%s", output); + endif + endif + + ## Copy files to "inst" and "inst/arch" (this is instead of 'make + ## install'). + files = fullfile (src, "FILES"); + instdir = fullfile (packdir, "inst"); + archdir = fullfile (packdir, "inst", getarch ()); + + ## Get file names. + if (exist (files, "file")) + [fid, msg] = fopen (files, "r"); + if (fid < 0) + error ("couldn't open %s: %s", files, msg); + endif + filenames = char (fread (fid))'; + fclose (fid); + if (filenames(end) == "\n") + filenames(end) = []; + endif + filenames = split_by (filenames, "\n"); + delete_idx = []; + for i = 1:length (filenames) + if (! all (isspace (filenames{i}))) + filenames{i} = fullfile (src, filenames{i}); + else + delete_idx(end+1) = i; + endif + endfor + filenames(delete_idx) = []; + else + m = dir (fullfile (src, "*.m")); + oct = dir (fullfile (src, "*.oct")); + mex = dir (fullfile (src, "*.mex")); + + filenames = cellfun (@(x) fullfile (src, x), + {m.name, oct.name, mex.name}, + "UniformOutput", false); + endif + + ## Split into architecture dependent and independent files. + if (isempty (filenames)) + idx = []; + else + idx = cellfun (@is_architecture_dependent, filenames); + endif + archdependent = filenames (idx); + archindependent = filenames (!idx); + + ## Copy the files. + if (! all (isspace ([filenames{:}]))) + if (! exist (instdir, "dir")) # fixindent + mkdir (instdir); + endif + if (! all (isspace ([archindependent{:}]))) + if (verbose) + printf ("copyfile"); + printf (" %s", archindependent{:}); + printf ("%s\n", instdir); + endif + [status, output] = copyfile (archindependent, instdir); + if (status != 1) + rm_rf (desc.dir); + error ("Couldn't copy files from 'src' to 'inst': %s", output); + endif + endif + if (! all (isspace ([archdependent{:}]))) + if (verbose) + printf ("copyfile"); + printf (" %s", archdependent{:}); + printf (" %s\n", archdir); + endif + if (! exist (archdir, "dir")) + mkdir (archdir); + endif + [status, output] = copyfile (archdependent, archdir); + if (status != 1) + rm_rf (desc.dir); + error ("Couldn't copy files from 'src' to 'inst': %s", output); + endif + endif + endif + endif +endfunction + +function pkg = extract_pkg (nm, pat) + fid = fopen (nm, "rt"); + pkg = ""; + if (fid >= 0) + while (! feof (fid)) + ln = fgetl (fid); + if (ln > 0) + t = regexp (ln, pat, "tokens"); + if (! isempty (t)) + pkg = cstrcat (pkg, "\n", t{1}{1}); + endif + endif + endwhile + if (! isempty (pkg)) + pkg = cstrcat (pkg, "\n"); + endif + fclose (fid); + endif +endfunction + +function create_pkgadddel (desc, packdir, nm, global_install) + instpkg = fullfile (desc.dir, nm); + instfid = fopen (instpkg, "wt"); + ## If it is exists, most of the PKG_* file should go into the + ## architecture dependent directory so that the autoload/mfilename + ## commands work as expected. The only part that doesn't is the + ## part in the main directory. + archdir = fullfile (getarchprefix (desc), cstrcat (desc.name, "-", + desc.version), getarch ()); + if (exist (getarchdir (desc, global_install), "dir")) + archpkg = fullfile (getarchdir (desc, global_install), nm); + archfid = fopen (archpkg, "at"); + else + archpkg = instpkg; + archfid = instfid; + endif + + if (archfid >= 0 && instfid >= 0) + ## Search all dot-m files for PKG commands. + lst = dir (fullfile (packdir, "inst", "*.m")); + for i = 1:length (lst) + nam = fullfile (packdir, "inst", lst(i).name); + fwrite (instfid, extract_pkg (nam, ['^[#%][#%]* *' nm ': *(.*)$'])); + endfor + + ## Search all C++ source files for PKG commands. + lst = dir (fullfile (packdir, "src", "*.cc")); + for i = 1:length (lst) + nam = fullfile (packdir, "src", lst(i).name); + fwrite (archfid, extract_pkg (nam, ['^//* *' nm ': *(.*)$'])); + fwrite (archfid, extract_pkg (nam, ['^/\** *' nm ': *(.*) *\*/$'])); + endfor + + ## Add developer included PKG commands. + packdirnm = fullfile (packdir, nm); + if (exist (packdirnm, "file")) + fid = fopen (packdirnm, "rt"); + if (fid >= 0) + while (! feof (fid)) + ln = fgets (fid); + if (ln > 0) + fwrite (archfid, ln); + endif + endwhile + fclose (fid); + endif + endif + + ## If the files is empty remove it. + fclose (instfid); + t = dir (instpkg); + if (t.bytes <= 0) + unlink (instpkg); + endif + + if (instfid != archfid) + fclose (archfid); + t = dir (archpkg); + if (t.bytes <= 0) + unlink (archpkg); + endif + endif + endif +endfunction + +function copy_files (desc, packdir, global_install) + ## Create the installation directory. + if (! exist (desc.dir, "dir")) + [status, output] = mkdir (desc.dir); + if (status != 1) + error ("couldn't create installation directory %s : %s", + desc.dir, output); + endif + endif + + octfiledir = getarchdir (desc); + + ## Copy the files from "inst" to installdir. + instdir = fullfile (packdir, "inst"); + if (! dirempty (instdir)) + [status, output] = copyfile (fullfile (instdir, "*"), desc.dir); + if (status != 1) + rm_rf (desc.dir); + error ("couldn't copy files to the installation directory"); + endif + if (exist (fullfile (desc.dir, getarch ()), "dir") && + ! strcmp (fullfile (desc.dir, getarch ()), octfiledir)) + if (! exist (octfiledir, "dir")) + ## Can be required to create upto three levels of dirs. + octm1 = fileparts (octfiledir); + if (! exist (octm1, "dir")) + octm2 = fileparts (octm1); + if (! exist (octm2, "dir")) + octm3 = fileparts (octm2); + if (! exist (octm3, "dir")) + [status, output] = mkdir (octm3); + if (status != 1) + rm_rf (desc.dir); + error ("couldn't create installation directory %s : %s", + octm3, output); + endif + endif + [status, output] = mkdir (octm2); + if (status != 1) + rm_rf (desc.dir); + error ("couldn't create installation directory %s : %s", + octm2, output); + endif + endif + [status, output] = mkdir (octm1); + if (status != 1) + rm_rf (desc.dir); + error ("couldn't create installation directory %s : %s", + octm1, output); + endif + endif + [status, output] = mkdir (octfiledir); + if (status != 1) + rm_rf (desc.dir); + error ("couldn't create installation directory %s : %s", + octfiledir, output); + endif + endif + [status, output] = movefile (fullfile (desc.dir, getarch (), "*"), + octfiledir); + rm_rf (fullfile (desc.dir, getarch ())); + + if (status != 1) + rm_rf (desc.dir); + rm_rf (octfiledir); + error ("couldn't copy files to the installation directory"); + endif + endif + + endif + + ## Create the "packinfo" directory. + packinfo = fullfile (desc.dir, "packinfo"); + [status, msg] = mkdir (packinfo); + if (status != 1) + rm_rf (desc.dir); + rm_rf (octfiledir); + error ("couldn't create packinfo directory: %s", msg); + endif + + ## Copy DESCRIPTION. + [status, output] = copyfile (fullfile (packdir, "DESCRIPTION"), packinfo); + if (status != 1) + rm_rf (desc.dir); + rm_rf (octfiledir); + error ("couldn't copy DESCRIPTION: %s", output); + endif + + ## Copy COPYING. + [status, output] = copyfile (fullfile (packdir, "COPYING"), packinfo); + if (status != 1) + rm_rf (desc.dir); + rm_rf (octfiledir); + error ("couldn't copy COPYING: %s", output); + endif + + ## If the file ChangeLog exists, copy it. + changelog_file = fullfile (packdir, "ChangeLog"); + if (exist (changelog_file, "file")) + [status, output] = copyfile (changelog_file, packinfo); + if (status != 1) + rm_rf (desc.dir); + rm_rf (octfiledir); + error ("couldn't copy ChangeLog file: %s", output); + endif + endif + + ## Is there an INDEX file to copy or should we generate one? + index_file = fullfile (packdir, "INDEX"); + if (exist(index_file, "file")) + [status, output] = copyfile (index_file, packinfo); + if (status != 1) + rm_rf (desc.dir); + rm_rf (octfiledir); + error ("couldn't copy INDEX file: %s", output); + endif + else + try + write_index (desc, fullfile (packdir, "inst"), + fullfile (packinfo, "INDEX"), global_install); + catch + rm_rf (desc.dir); + rm_rf (octfiledir); + rethrow (lasterror ()); + end_try_catch + endif + + ## Is there an 'on_uninstall.m' to install? + fon_uninstall = fullfile (packdir, "on_uninstall.m"); + if (exist (fon_uninstall, "file")) + [status, output] = copyfile (fon_uninstall, packinfo); + if (status != 1) + rm_rf (desc.dir); + rm_rf (octfiledir); + error ("couldn't copy on_uninstall.m: %s", output); + endif + endif + + ## Is there a doc/ directory that needs to be installed? + docdir = fullfile (packdir, "doc"); + if (exist (docdir, "dir") && ! dirempty (docdir)) + [status, output] = copyfile (docdir, desc.dir); + endif + + ## Is there a bin/ directory that needs to be installed? + ## FIXME: Need to treat architecture dependent files in bin/ + bindir = fullfile (packdir, "bin"); + if (exist (bindir, "dir") && ! dirempty (bindir)) + [status, output] = copyfile (bindir, desc.dir); + endif +endfunction + +function finish_installation (desc, packdir, global_install) + ## Is there a post-install to call? + if (exist (fullfile (packdir, "post_install.m"), "file")) + wd = pwd (); + try + cd (packdir); + post_install (desc); + cd (wd); + catch + cd (wd); + rm_rf (desc.dir); + rm_rf (getarchdir (desc), global_install); + rethrow (lasterror ()); + end_try_catch + endif +endfunction + +function generate_lookfor_cache (desc) + dirs = split_by (genpath (desc.dir), pathsep ()); + for i = 1 : length (dirs) + gen_doc_cache (fullfile (dirs{i}, "doc-cache"), dirs{i}); + endfor +endfunction + +## Make sure the package contains the essential files. +function verify_directory (dir) + needed_files = {"COPYING", "DESCRIPTION"}; + for f = needed_files + if (! exist (fullfile (dir, f{1}), "file")) + error ("package is missing file: %s", f{1}); + endif + endfor +endfunction + +## Parse the DESCRIPTION file. +function desc = get_description (filename) + [fid, msg] = fopen (filename, "r"); + if (fid == -1) + error ("the DESCRIPTION file %s could not be read: %s", filename, msg); + endif + + desc = struct (); + + line = fgetl (fid); + while (line != -1) + if (line(1) == "#") + ## Comments, do nothing. + elseif (isspace(line(1))) + ## Continuation lines + if (exist ("keyword", "var") && isfield (desc, keyword)) + desc.(keyword) = cstrcat (desc.(keyword), " ", rstrip(line)); + endif + else + ## Keyword/value pair + colon = find (line == ":"); + if (length (colon) == 0) + disp ("skipping line"); + else + colon = colon(1); + keyword = tolower (strip (line(1:colon-1))); + value = strip (line (colon+1:end)); + if (length (value) == 0) + fclose (fid); + error ("the keyword %s has an empty value", desc.keywords{end}); + endif + desc.(keyword) = value; + endif + endif + line = fgetl (fid); + endwhile + fclose (fid); + + ## Make sure all is okay. + needed_fields = {"name", "version", "date", "title", ... + "author", "maintainer", "description"}; + for f = needed_fields + if (! isfield (desc, f{1})) + error ("description is missing needed field %s", f{1}); + endif + endfor + desc.version = fix_version (desc.version); + if (isfield (desc, "depends")) + desc.depends = fix_depends (desc.depends); + else + desc.depends = ""; + endif + desc.name = tolower (desc.name); +endfunction + +## Make sure the version string v is a valid x.y.z version string +## Examples: "0.1" => "0.1.0", "monkey" => error(...). +function out = fix_version (v) + dots = find (v == "."); + if (length (dots) == 1) + major = str2num (v(1:dots-1)); + minor = str2num (v(dots+1:end)); + if (length (major) != 0 && length (minor) != 0) + out = sprintf ("%d.%d.0", major, minor); + return; + endif + elseif (length (dots) == 2) + major = str2num (v(1:dots(1)-1)); + minor = str2num (v(dots(1)+1:dots(2)-1)); + rev = str2num (v(dots(2)+1:end)); + if (length (major) != 0 && length (minor) != 0 && length (rev) != 0) + out = sprintf ("%d.%d.%d", major, minor, rev); + return; + endif + endif + error ("bad version string: %s", v); +endfunction + +## Make sure the depends field is of the right format. +## This function returns a cell of structures with the following fields: +## package, version, operator +function deps_cell = fix_depends (depends) + deps = split_by (tolower (depends), ","); + deps_cell = cell (1, length (deps)); + + ## For each dependency. + for i = 1:length (deps) + dep = deps{i}; + lpar = find (dep == "("); + rpar = find (dep == ")"); + ## Does the dependency specify a version + ## Example: package(>= version). + if (length (lpar) == 1 && length (rpar) == 1) + package = tolower (strip (dep(1:lpar-1))); + sub = dep(lpar(1)+1:rpar(1)-1); + parts = strsplit (sub, " ", true); + if (length (parts) != 2) + error ("incorrect syntax for dependency `%s' in the DESCRIPTION file\n", + dep); + endif + operator = parts{1}; + if (! any (strcmp (operator, {">", ">=", "<=", "<", "=="}))) + error ("unsupported operator: %s", operator); + endif + version = fix_version (parts{2}); + + ## If no version is specified for the dependency + ## we say that the version should be greater than + ## or equal to "0.0.0". + else + package = tolower (strip (dep)); + operator = ">="; + version = "0.0.0"; + endif + deps_cell{i} = struct ("package", package, "operator", operator, + "version", version); + endfor +endfunction + +## Strip the text of spaces from the right +## Example: " hello world " => " hello world" +## FIXME -- is this the same as deblank? +function text = rstrip (text) + chars = find (! isspace (text)); + if (length (chars) > 0) + ## FIXME: shouldn't it be text = text(1:chars(end)); + text = text (chars(1):end); + else + text = ""; + endif +endfunction + +## Strip the text of spaces from the left and the right. +## Example: " hello world " => "hello world" +function text = strip (text) + chars = find (! isspace (text)); + if (length (chars) > 0) + text = text(chars(1):chars(end)); + else + text = ""; + endif +endfunction + +## Split the text into a cell array of strings by sep. +## Example: "A, B" => {"A", "B"} (with sep = ",") +function out = split_by (text, sep) + out = strtrim (strsplit (text, sep)); +endfunction + +## Create an INDEX file for a package that doesn't provide one. +## 'desc' describes the package. +## 'dir' is the 'inst' directory in temporary directory. +## 'index_file' is the name (including path) of resulting INDEX file. +function write_index (desc, dir, index_file, global_install) + ## Get names of functions in dir + [files, err, msg] = readdir (dir); + if (err) + error ("couldn't read directory %s: %s", dir, msg); + endif + + ## Check for architecture dependent files. + tmpdir = getarchdir (desc); + if (exist (tmpdir, "dir")) + [files2, err, msg] = readdir (tmpdir); + if (err) + error ("couldn't read directory %s: %s", tmpdir, msg); + endif + files = [files; files2]; + endif + + functions = {}; + for i = 1:length (files) + file = files{i}; + lf = length (file); + if (lf > 2 && strcmp (file(end-1:end), ".m")) + functions{end+1} = file(1:end-2); + elseif (lf > 4 && strcmp (file(end-3:end), ".oct")) + functions{end+1} = file(1:end-4); + endif + endfor + + ## Does desc have a categories field? + if (! isfield (desc, "categories")) + error ("the DESCRIPTION file must have a Categories field, when no INDEX file is given"); + endif + categories = split_by (desc.categories, ","); + if (length (categories) < 1) + error ("the Category field is empty"); + endif + + ## Write INDEX. + fid = fopen (index_file, "w"); + if (fid == -1) + error ("couldn't open %s for writing.", index_file); + endif + fprintf (fid, "%s >> %s\n", desc.name, desc.title); + fprintf (fid, "%s\n", categories{1}); + fprintf (fid, " %s\n", functions{:}); + fclose (fid); +endfunction + +function bad_deps = get_unsatisfied_deps (desc, installed_pkgs_lst) + bad_deps = {}; + + ## For each dependency. + for i = 1:length (desc.depends) + dep = desc.depends{i}; + + ## Is the current dependency Octave? + if (strcmp (dep.package, "octave")) + if (! compare_versions (OCTAVE_VERSION, dep.version, dep.operator)) + bad_deps{end+1} = dep; + endif + ## Is the current dependency not Octave? + else + ok = false; + for i = 1:length (installed_pkgs_lst) + cur_name = installed_pkgs_lst{i}.name; + cur_version = installed_pkgs_lst{i}.version; + if (strcmp (dep.package, cur_name) + && compare_versions (cur_version, dep.version, dep.operator)) + ok = true; + break; + endif + endfor + if (! ok) + bad_deps{end+1} = dep; + endif + endif + endfor +endfunction + +function [out1, out2] = installed_packages (local_list, global_list) + ## Get the list of installed packages. + try + local_packages = load (local_list).local_packages; + catch + local_packages = {}; + end_try_catch + try + global_packages = load (global_list).global_packages; + catch + global_packages = {}; + end_try_catch + installed_pkgs_lst = {local_packages{:}, global_packages{:}}; + + ## Eliminate duplicates in the installed package list. + ## Locally installed packages take precedence. + dup = []; + for i = 1:length (installed_pkgs_lst) + if (find (dup, i)) + continue; + endif + for j = (i+1):length (installed_pkgs_lst) + if (find (dup, j)) + continue; + endif + if (strcmp (installed_pkgs_lst{i}.name, installed_pkgs_lst{j}.name)) + dup = [dup, j]; + endif + endfor + endfor + if (! isempty(dup)) + installed_pkgs_lst(dup) = []; + endif + + ## Now check if the package is loaded. + tmppath = strrep (path(), "\\", "/"); + for i = 1:length (installed_pkgs_lst) + if (findstr (tmppath, strrep (installed_pkgs_lst{i}.dir, "\\", "/"))) + installed_pkgs_lst{i}.loaded = true; + else + installed_pkgs_lst{i}.loaded = false; + endif + endfor + for i = 1:length (local_packages) + if (findstr (tmppath, strrep (local_packages{i}.dir, "\\", "/"))) + local_packages{i}.loaded = true; + else + local_packages{i}.loaded = false; + endif + endfor + for i = 1:length (global_packages) + if (findstr (tmppath, strrep (global_packages{i}.dir, "\\", "/"))) + global_packages{i}.loaded = true; + else + global_packages{i}.loaded = false; + endif + endfor + + ## Should we return something? + if (nargout == 2) + out1 = local_packages; + out2 = global_packages; + return; + elseif (nargout == 1) + out1 = installed_pkgs_lst; + return; + endif + + ## We shouldn't return something, so we'll print something. + num_packages = length (installed_pkgs_lst); + if (num_packages == 0) + printf ("no packages installed.\n"); + return; + endif + + ## Compute the maximal lengths of name, version, and dir. + h1 = "Package Name"; + h2 = "Version"; + h3 = "Installation directory"; + max_name_length = length (h1); + max_version_length = length (h2); + names = cell (num_packages, 1); + for i = 1:num_packages + max_name_length = max (max_name_length, + length (installed_pkgs_lst{i}.name)); + max_version_length = max (max_version_length, + length (installed_pkgs_lst{i}.version)); + names{i} = installed_pkgs_lst{i}.name; + endfor + max_dir_length = terminal_size()(2) - max_name_length - ... + max_version_length - 7; + if (max_dir_length < 20) + max_dir_length = Inf; + endif + + h1 = postpad (h1, max_name_length + 1, " "); + h2 = postpad (h2, max_version_length, " ");; + + ## Print a header. + header = sprintf("%s | %s | %s\n", h1, h2, h3); + printf (header); + tmp = sprintf (repmat ("-", 1, length(header)-1)); + tmp(length(h1)+2) = "+"; + tmp(length(h1)+length(h2)+5) = "+"; + printf ("%s\n", tmp); + + ## Print the packages. + format = sprintf ("%%%ds %%1s| %%%ds | %%s\n", max_name_length, + max_version_length); + [dummy, idx] = sort (names); + for i = 1:num_packages + cur_name = installed_pkgs_lst{idx(i)}.name; + cur_version = installed_pkgs_lst{idx(i)}.version; + cur_dir = installed_pkgs_lst{idx(i)}.dir; + if (length (cur_dir) > max_dir_length) + first_char = length (cur_dir) - max_dir_length + 4; + first_filesep = strfind (cur_dir(first_char:end), filesep()); + if (! isempty (first_filesep)) + cur_dir = cstrcat ("...", + cur_dir((first_char + first_filesep(1) - 1):end)); + else + cur_dir = cstrcat ("...", cur_dir(first_char:end)); + endif + endif + if (installed_pkgs_lst{idx(i)}.loaded) + cur_loaded = "*"; + else + cur_loaded = " "; + endif + printf (format, cur_name, cur_loaded, cur_version, cur_dir); + endfor +endfunction + +function load_packages (files, handle_deps, local_list, global_list) + installed_pkgs_lst = installed_packages (local_list, global_list); + num_packages = length (installed_pkgs_lst); + + ## Read package names and installdirs into a more convenient format. + pnames = pdirs = cell (1, num_packages); + for i = 1:num_packages + pnames{i} = installed_pkgs_lst{i}.name; + pdirs{i} = installed_pkgs_lst{i}.dir; + endfor + + ## Load all. + if (length (files) == 1 && strcmp (files{1}, "all")) + idx = [1:length(installed_pkgs_lst)]; + ## Load auto. + elseif (length (files) == 1 && strcmp (files{1}, "auto")) + idx = []; + for i = 1:length (installed_pkgs_lst) + if (exist (fullfile (pdirs{i}, "packinfo", ".autoload"), "file")) + idx (end + 1) = i; + endif + endfor + ## Load package_name1 ... + else + idx = []; + for i = 1:length (files) + idx2 = find (strcmp (pnames, files{i})); + if (! any (idx2)) + error ("package %s is not installed", files{i}); + endif + idx (end + 1) = idx2; + endfor + endif + + ## Load the packages, but take care of the ordering of dependencies. + load_packages_and_dependencies (idx, handle_deps, installed_pkgs_lst, true); +endfunction + +function unload_packages (files, handle_deps, local_list, global_list) + installed_pkgs_lst = installed_packages (local_list, global_list); + num_packages = length (installed_pkgs_lst); + + ## Read package names and installdirs into a more convenient format. + pnames = pdirs = cell (1, num_packages); + for i = 1:num_packages + pnames{i} = installed_pkgs_lst{i}.name; + pdirs{i} = installed_pkgs_lst{i}.dir; + pdeps{i} = installed_pkgs_lst{i}.depends; + endfor + + ## Get the current octave path. + p = split_by (path(), pathsep ()); + + if (length (files) == 1 && strcmp (files{1}, "all")) + ## Unload all. + dirs = pdirs; + desc = installed_pkgs_lst; + else + ## Unload package_name1 ... + dirs = {}; + desc = {}; + for i = 1:length (files) + idx = strcmp (pnames, files{i}); + if (! any (idx)) + error ("package %s is not installed", files{i}); + endif + dirs{end+1} = pdirs{idx}; + desc{end+1} = installed_pkgs_lst{idx}; + endfor + endif + + ## Check for architecture dependent directories. + archdirs = {}; + for i = 1:length (dirs) + tmpdir = getarchdir (desc{i}); + if (exist (tmpdir, "dir")) + archdirs{end+1} = dirs{i}; + archdirs{end+1} = tmpdir; + else + archdirs{end+1} = dirs{i}; + endif + endfor + + ## Unload the packages. + for i = 1:length (archdirs) + d = archdirs{i}; + idx = strcmp (p, d); + if (any (idx)) + rmpath (d); + ## FIXME: We should also check if we need to remove items from + ## EXEC_PATH. + endif + endfor +endfunction + +function [status_out, msg_out] = rm_rf (dir) + if (exist (dir)) + crr = confirm_recursive_rmdir (); + unwind_protect + confirm_recursive_rmdir (false); + [status, msg] = rmdir (dir, "s"); + unwind_protect_cleanup + confirm_recursive_rmdir (crr); + end_unwind_protect + else + status = 1; + msg = ""; + endif + if (nargout > 0) + status_out = status; + endif + if (nargout > 1) + msg_out = msg; + endif +endfunction + +function emp = dirempty (nm, ign) + if (exist (nm, "dir")) + if (nargin < 2) + ign = {".", ".."}; + else + ign = [{".", ".."}, ign]; + endif + l = dir (nm); + for i = 1:length (l) + found = false; + for j = 1:length (ign) + if (strcmp (l(i).name, ign{j})) + found = true; + break; + endif + endfor + if (! found) + emp = false; + return + endif + endfor + emp = true; + else + emp = true; + endif +endfunction + +function arch = getarch () + persistent _arch = cstrcat (octave_config_info("canonical_host_type"), ... + "-", octave_config_info("api_version")); + arch = _arch; +endfunction + +function archprefix = getarchprefix (desc, global_install) + if ((nargin == 2 && global_install) || (nargin < 2 && issuperuser ())) + archprefix = fullfile (octave_config_info ("libexecdir"), "octave", + "packages", cstrcat(desc.name, "-", desc.version)); + else + archprefix = desc.dir; + endif +endfunction + +function archdir = getarchdir (desc) + archdir = fullfile (desc.archprefix, getarch()); +endfunction + +function s = issuperuser () + if ((ispc () && ! isunix ()) || (geteuid() == 0)) + s = true; + else + s = false; + endif +endfunction + +function [status, output] = shell (cmd) + persistent have_sh; + + cmd = strrep (cmd, "\\", "/"); + if (ispc () && ! isunix ()) + if (isempty(have_sh)) + if (system("sh.exe -c \"exit\"")) + have_sh = false; + else + have_sh = true; + endif + endif + if (have_sh) + [status, output] = system (cstrcat ("sh.exe -c \"", cmd, "\"")); + else + error ("Can not find the command shell") + endif + else + [status, output] = system (cmd); + endif +endfunction + +function newdesc = save_order (desc) + newdesc = {}; + for i = 1 : length(desc) + deps = desc{i}.depends; + if (isempty (deps) || (length (deps) == 1 && + strcmp(deps{1}.package, "octave"))) + newdesc {end + 1} = desc{i}; + else + tmpdesc = {}; + for k = 1 : length (deps) + for j = 1 : length (desc) + if (strcmp (desc{j}.name, deps{k}.package)) + tmpdesc{end+1} = desc{j}; + break; + endif + endfor + endfor + if (! isempty (tmpdesc)) + newdesc = {newdesc{:}, save_order(tmpdesc){:}, desc{i}}; + else + newdesc{end+1} = desc{i}; + endif + endif + endfor + ## Eliminate the duplicates. + idx = []; + for i = 1 : length (newdesc) + for j = (i + 1) : length (newdesc) + if (strcmp (newdesc{i}.name, newdesc{j}.name)) + idx (end + 1) = j; + endif + endfor + endfor + newdesc(idx) = []; +endfunction + +function load_packages_and_dependencies (idx, handle_deps, installed_pkgs_lst, + global_install) + idx = load_package_dirs (idx, [], handle_deps, installed_pkgs_lst); + dirs = {}; + execpath = EXEC_PATH (); + for i = idx; + ndir = installed_pkgs_lst{i}.dir; + dirs{end+1} = ndir; + if (exist (fullfile (dirs{end}, "bin"), "dir")) + execpath = cstrcat (fullfile (dirs{end}, "bin"), ":", execpath); + endif + tmpdir = getarchdir (installed_pkgs_lst{i}); + if (exist (tmpdir, "dir")) + dirs{end + 1} = tmpdir; + if (exist (fullfile (dirs{end}, "bin"), "dir")) + execpath = cstrcat (fullfile (dirs{end}, "bin"), ":", execpath); + endif + endif + endfor + + ## Load the packages. + if (length (dirs) > 0) + addpath (dirs{:}); + endif + + ## Add the binaries to exec_path. + if (! strcmp (EXEC_PATH, execpath)) + EXEC_PATH (execpath); + endif +endfunction + +function idx = load_package_dirs (lidx, idx, handle_deps, installed_pkgs_lst) + for i = lidx + if (isfield (installed_pkgs_lst{i}, "loaded") && + installed_pkgs_lst{i}.loaded) + continue; + else + if (handle_deps) + deps = installed_pkgs_lst{i}.depends; + if ((length (deps) > 1) || (length (deps) == 1 && + ! strcmp(deps{1}.package, "octave"))) + tmplidx = []; + for k = 1 : length (deps) + for j = 1 : length (installed_pkgs_lst) + if (strcmp (installed_pkgs_lst{j}.name, deps{k}.package)) + tmplidx (end + 1) = j; + break; + endif + endfor + endfor + idx = load_package_dirs (tmplidx, idx, handle_deps, + installed_pkgs_lst); + endif + endif + if (isempty (find(idx == i))) + idx (end + 1) = i; + endif + endif + endfor +endfunction + +function dep = is_architecture_dependent (nm) + persistent archdepsuffix = {".oct",".mex",".a",".lib",".so",".so.*",".dll","dylib"}; + + dep = false; + for i = 1 : length (archdepsuffix) + ext = archdepsuffix{i}; + if (ext(end) == "*") + isglob = true; + ext(end) = []; + else + isglob = false; + endif + pos = findstr (nm, ext); + if (pos) + if (! isglob && (length(nm) - pos(end) != length(ext) - 1)) + continue; + endif + dep = true; + break; + endif + endfor +endfunction diff --git a/test/indent/prolog.prolog b/test/indent/prolog.prolog new file mode 100644 index 00000000000..8b96cd56a33 --- /dev/null +++ b/test/indent/prolog.prolog @@ -0,0 +1,224 @@ +%% -*- mode: prolog; coding: utf-8 -*- + +%% wf(+E) +%% Vérifie que E est une expression syntaxiquement correcte. +wf(X) :- atom(X); integer(X); var(X). %Une variable ou un entier. +wf(lambda(X, T, B)) :- atom(X), wf(T), wf(B). %Une fonction. +wf(app(E1, E2)) :- wf(E1), wf(E2). %Un appel de fonction. +wf(pi(X, T, B)) :- atom(X), wf(T), wf(B). %Le type d'une fonction. + +%% Éléments additionnels utilisés dans le langage source. +wf(lambda(X, B)) :- atom(X), wf(B). +wf(let(X, E1, E2)) :- atom(X), wf(E1), wf(E2). +wf(let(X, T, E1, E2)) :- atom(X), wf(T), wf(E1), wf(E2). +wf((T1 -> T2)) :- wf(T1), wf(T2). +wf(forall(X, T, B)) :- atom(X), wf(T), wf(B). +wf(fix(X,T,E1,E2)) :- atom(X), wf(T), wf(E1), wf(E2). +wf(fix(X,E1,E2)) :- atom(X), wf(E1), wf(E2). +wf(app(E1,E2,E3)) :- wf(E1), wf(E2), wf(E3). +wf(app(E1,E2,E3,E4)) :- wf(E1), wf(E2), wf(E3), wf(E4). + +%% subst(+X, +V, +FV, +Ei, -Eo) +%% Remplace X par V dans Ei. Les variables qui apparaissent libres dans +%% V et peuvent aussi apparaître dans Ei doivent toutes être inclues +%% dans l'environnement FV. +subst(X, V, _, X, E) :- !, E = V. +subst(_, _, _, Y, Y) :- atom(Y); integer(Y). +%% Residualize the substitution when applied to an uninstantiated variable. +%% subst(X, V, _, Y, app(lambda(X,_,Y),V)) :- var(Y). +%% Rather than residualize and leave us with unifications that fail, let's +%% rather assume that Y will not refer to X. +subst(X, V, _, Y, Y) :- var(Y). +subst(X, V, FV, lambda(Y, Ti, Bi), lambda(Y1, To, Bo)) :- + subst(X, V, FV, Ti, To), + (X = Y -> + %% If X is equal to Y, X is shadowed, so no subst can take place. + Y1 = Y, Bo = Bi; + (member((Y, _), FV) -> + %% If Y appears in FV, it can appear in V, so we need to + %% rename it to avoid name capture. + new_atom(Y, Y1), + subst(Y, Y1, [], Bi, Bi1); + Y1 = Y, Bi1 = Bi), + %% Perform substitution on the body. + subst(X, V, FV, Bi1, Bo)). +subst(X, V, FV, pi(Y, Ti, Bi), pi(Y1, To, Bo)) :- + subst(X, V, FV, lambda(Y, Ti, Bi), lambda(Y1, To, Bo)). +subst(X, V, FV, forall(Y, Ti, Bi), forall(Y1, To, Bo)) :- + subst(X, V, FV, lambda(Y, Ti, Bi), lambda(Y1, To, Bo)). +subst(X, V, FV, app(E1i, E2i), app(E1o, E2o)) :- + subst(X, V, FV, E1i, E1o), subst(X, V, FV, E2i, E2o). + +%% apply(+F, +Arg, +Env, -E) +apply(lambda(X, _, B), Arg, Env, E) :- \+ var(B), subst(X, Arg, Env, B, E). +apply(app(plus, N1), N2, _, N) :- integer(N1), integer(N2), N is N1 + N2. +apply(app(minus, N1), N2, _, N) :- integer(N1), integer(N2), N is N1 - N2. + + +%% normalize(+E1, +Env, -E2) +%% Applique toutes les réductions possibles sur E1. +normalize(X, _, X) :- integer(X); var(X); atom(X). +%% normalize(X, Env, E) :- atom(X), member((X, E), Env). +normalize(lambda(X, T, B), Env, lambda(X, Tn, Bn)) :- + normalize(T, [(X,T)|Env], Tn), normalize(B, [(X,T)|Env], Bn). +normalize(pi(X, T, B), Env, pi(X, Tn, Bn)) :- + normalize(T, [(X,T)|Env], Tn), normalize(B, [(X,T)|Env], Bn). +normalize(forall(X, T, B), Env, forall(X, Tn, Bn)) :- + normalize(T, [(X,T)|Env], Tn), normalize(B, [(X,T)|Env], Bn). +normalize(app(E1, E2), Env, En) :- + normalize(E1, Env, E1n), + normalize(E2, Env, E2n), + (apply(E1n, E2n, Env, E) -> + normalize(E, Env, En); + En = app(E1n, E2n)). + +%% infer(+E, +Env, -T) +%% Infère le type de E dans Env. On essaie d'être permissif, dans le sens +%% que l'on présume que l'expression est typée correctement. +infer(X, _, int) :- integer(X). +infer(X, _, _) :- var(X). %Une expression encore inconnue. +infer(X, Env, T) :- + atom(X), + (member((X, T1), Env) -> + %% X est déjà dans Env: vérifie que le type est correct. + T = T1; + %% X est une variable libre. + true). +infer(lambda(X,T,B), Env, pi(Y,T,TB)) :- + infer(B, [(X,T)|Env], TBx), + (var(Y) -> + Y = X, TB = TBx; + subst(X, Y, Env, TBx, TB)). +infer(app(E1, E2), Env, Tn) :- + infer(E1, Env, T1), + (T1 = pi(X,T2,B); T1 = forall(X,T2,B)), + infer(E2, Env, T2), + subst(X, E2, Env, B, T), + normalize(T, Env, Tn). +infer(pi(X,T1,T2), Env, type) :- + infer(T1, Env, type), + infer(T2, [(X,T1)|Env], type). +infer(forall(X,T1,T2), Env, type) :- + infer(T1, Env, type), + infer(T2, [(X,T1)|Env], type). + +%% freevars(+E, +Env, -Vs) +%% Renvoie les variables libres de E. Vs est une liste associative +%% où chaque élément est de la forme (X,T) où X est une variable et T est +%% son type. +freevars(X, _, []) :- integer(X). +freevars(X, Env, Vs) :- + atom(X), + (member((X,_), Env) -> + %% Variable liée. + Vs = []; + %% Variable libre. Type inconnu :-( + Vs = [(X,_)]). +%% Les variables non-instanciées peuvent être remplacées par des paramètres +%% qui seront liés par `closetype' selon le principe de Hindley-Milner. +freevars(X, _, [(X, _)]) :- var(X), new_atom(X). +freevars(app(E1, E2), Env, Vs) :- + freevars(E1, Env, Vs1), + append(Vs1, Env, Env1), + freevars(E2, Env1, Vs2), + append(Vs1, Vs2, Vs). +freevars(lambda(X, T, B), Env, Vs) :- + freevars(T, Env, TVs), + append(TVs, Env, Env1), + freevars(B, [(X,T)|Env1], BVs), + append(TVs, BVs, Vs). +freevars(pi(X, T, B), Env, Vs) :- freevars(lambda(X, T, B), Env, Vs). +freevars(forall(X, T, B), Env, Vs) :- freevars(lambda(X, T, B), Env, Vs). + +%% close(+Eo, +To, +Vs, -Ec, -Tc) +%% Ferme un type ouvert To en liant chaque variable libre (listées dans Vs) +%% avec `forall'. +closetype(E, T, [], E, T). +closetype(Eo, To, [(X,T)|Vs], lambda(X, T, Ec), forall(X, T, Tc)) :- + closetype(Eo, To, Vs, Ec, Tc). + +%% elab_type(+Ee, +Te, +Env, -Eg, -Tg) +%% Ajoute les arguments implicites de E:T. +generalize(Ee, Te, Env, Eg, Tg) :- + freevars(Te, Env, Vs), + append(Vs, Env, EnvX), + %% Essaie d'instancier les types des paramètres que `generalize' vient + %% d'ajouter. + infer(Te, EnvX, type), + closetype(Ee, Te, Vs, Eg, Tg). + +%% instantiate(+X, +T, -E) +%% Utilise la variable X de type T. Le résultat E est X auquel on ajoute +%% tous les arguments implicites (de valeur inconnue). +instantiate(X, T, X) :- var(T), !. +instantiate(X, forall(_, _, T), app(E, _)) :- !, instantiate(X, T, E). +instantiate(X, _, X). + +%% elaborate(+E1, +Env, -E2) +%% Transforme E1 en une expression E2 où le sucre syntaxique a été éliminé +%% et où les arguments implicites ont été rendus explicites. +elaborate(X, _, X) :- integer(X); var(X). +elaborate(X, Env, E) :- + atom(X), + (member((X, T), Env) -> + instantiate(X, T, E); + %% Si X n'est pas dans l'environnement, c'est une variable libre que + %% l'on voudra probablement généraliser. + X = E). +elaborate(lambda(X, T, B), Env, lambda(X, Te, Be)) :- + elaborate(T, Env, Te), + elaborate(B, [(X,Te)|Env], Be). +elaborate(pi(X, T, B), Env, pi(X, Te, Be)) :- + elaborate(T, Env, Te), + elaborate(B, [(X,Te)|Env], Be). +elaborate(app(E1, E2), Env, app(E1e, E2e)) :- + elaborate(E1, Env, E1e), + elaborate(E2, Env, E2e). +elaborate(let(X, T, E1, E2), Env, app(lambda(X, Tg, E2e), E1g)) :- + elaborate(E1, Env, E1e), + elaborate(T, Env, Te), + infer(E1e, Env, Te), + generalize(E1e, Te, Env, E1g, Tg), + elaborate(E2, [(X,Te)|Env], E2e). +%% Expansion du sucre syntaxique. +elaborate((T1 -> T2), Env, Ee) :- + new_atom(X), elaborate(pi(X, T1, T2), Env, Ee). +elaborate(app(E1, E2, E3, E4), Env, Ee) :- + elaborate(app(app(E1,E2,E3),E4), Env, Ee). +elaborate(app(E1, E2, E3), Env, Ee) :- elaborate(app(app(E1,E2),E3), Env, Ee). +elaborate(lambda(X, B), Env, Ee) :- elaborate(lambda(X, _, B), Env, Ee). +elaborate(let(X, E1, E2), Env, Ee) :- elaborate(let(X, _, E1, E2), Env, Ee). +elaborate(fix(F,B,E), Env, Ee) :- elaborate(fix(F,_,B,E), Env, Ee). +elaborate(fix(F,T,B,E), Env, Ee) :- + elaborate(let(F,T,app(fix,lambda(F,T,B)),E), Env, Ee). + +%% elab_bindings(+TS, +Env, -TS). +%% Applique `elaborate' sur l'environnment de type TS. +elab_tenv([], _, []). +elab_tenv([(X,T)|TS], Env, [(X, Tg)|TSe]) :- + elaborate(T, Env, Te), + infer(Te, Env, type), + generalize(_, Te, Env, _, Tg), + elab_tenv(TS, [(X, Tg)|Env], TSe). + + +%% elaborate(+E1, -E2) +%% Comme le `elaborate' ci-dessus, mais avec un environnement par défaut. +elaborate(SRC, E) :- + elab_tenv([(int, type), + (fix, ((t -> t) -> t)), + %% list: type → int → type + (list, (type -> int -> type)), + %% plus: int → int → int + (plus, (int -> int -> int)), + %% minus: int → int → int + (minus, (int -> int -> int)), + %% nil: list t 0 + (nil, app(app(list,t),0)), + %% cons: t -> list t n → list t (n + 1) + (cons, (t -> app(app(list,t),n) -> + app(app(list,t), app(app(plus,n),1)))) %fixindent + ], + [(type,type)], + Env), + elaborate(SRC, Env, E). diff --git a/test/occur-testsuite.el b/test/occur-testsuite.el new file mode 100644 index 00000000000..a4756c49e2a --- /dev/null +++ b/test/occur-testsuite.el @@ -0,0 +1,347 @@ +;;; occur-testsuite.el --- Test suite for occur. + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Juri Linkov <juri@jurta.org> +;; Keywords: matching, internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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 General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Type M-x test-occur RET to test the functionality of `occur'. + +;;; Code: + +(defconst occur-tests + '( + ;; * Test one-line matches (at bob, eob, bol, eol). + ("x" 0 "\ +xa +b +cx +xd +xex +fx +" "\ +5 matches for \"x\" in buffer: *temp* + 1:xa + 3:cx + 4:xd + 5:xex + 6:fx +") + ;; * Test multi-line matches, this is the first test from + ;; http://lists.gnu.org/archive/html/emacs-devel/2005-06/msg01008.html + ;; where numbers are replaced with letters. + ("a\na" 0 "\ +a +a +a +a +a +" "\ +2 matches for \"a^Ja\" in buffer: *temp* + 1:a + :a + 3:a + :a +") + ;; * Test multi-line matches, this is the second test from + ;; http://lists.gnu.org/archive/html/emacs-devel/2005-06/msg01008.html + ;; where numbers are replaced with letters. + ("a\nb" 0 "\ +a +b +c +a +b +" "\ +2 matches for \"a^Jb\" in buffer: *temp* + 1:a + :b + 4:a + :b +") + ;; * Test line numbers for multi-line matches with empty last match line. + ("a\n" 0 "\ +a + +c +a + +" "\ +2 matches for \"a^J\" in buffer: *temp* + 1:a + : + 4:a + : +") + ;; * Test multi-line matches with 3 match lines. + ("x\n.x\n" 0 "\ +ax +bx +c +d +ex +fx +" "\ +2 matches for \"x^J.x^J\" in buffer: *temp* + 1:ax + :bx + :c + 5:ex + :fx + : +") + ;; * Test non-overlapping context lines with matches at bob/eob. + ("x" 1 "\ +ax +b +c +d +ex +f +g +hx +" "\ +3 matches for \"x\" in buffer: *temp* + 1:ax + :b +------- + :d + 5:ex + :f +------- + :g + 8:hx +") + ;; * Test non-overlapping context lines with matches not at bob/eob. + ("x" 1 "\ +a +bx +c +d +ex +f +" "\ +2 matches for \"x\" in buffer: *temp* + :a + 2:bx + :c +------- + :d + 5:ex + :f +") + ;; * Test overlapping context lines with matches at bob/eob. + ("x" 2 "\ +ax +bx +c +dx +e +f +gx +h +i +j +kx +" "\ +5 matches for \"x\" in buffer: *temp* + 1:ax + 2:bx + :c + 4:dx + :e + :f + 7:gx + :h + :i + :j + 11:kx +") + ;; * Test overlapping context lines with matches not at bob/eob. + ("x" 2 "\ +a +b +cx +d +e +f +gx +h +i +" "\ +2 matches for \"x\" in buffer: *temp* + :a + :b + 3:cx + :d + :e + :f + 7:gx + :h + :i +") + ;; * Test overlapping context lines with empty first and last line.. + ("x" 2 "\ + +b +cx +d +e +f +gx +h + +" "\ +2 matches for \"x\" in buffer: *temp* + : + :b + 3:cx + :d + :e + :f + 7:gx + :h + : +") + ;; * Test multi-line overlapping context lines. + ("x\n.x" 2 "\ +ax +bx +c +d +ex +fx +g +h +i +jx +kx +" "\ +3 matches for \"x^J.x\" in buffer: *temp* + 1:ax + :bx + :c + :d + 5:ex + :fx + :g + :h + :i + 10:jx + :kx +") + ;; * Test multi-line non-overlapping context lines. + ("x\n.x" 2 "\ +ax +bx +c +d +e +f +gx +hx +" "\ +2 matches for \"x^J.x\" in buffer: *temp* + 1:ax + :bx + :c + :d +------- + :e + :f + 7:gx + :hx +") + ;; * Test non-overlapping negative (before-context) lines. + ("x" -2 "\ +a +bx +c +d +e +fx +g +h +ix +" "\ +3 matches for \"x\" in buffer: *temp* + :a + 2:bx +------- + :d + :e + 6:fx +------- + :g + :h + 9:ix +") + ;; * Test overlapping negative (before-context) lines. + ("x" -3 "\ +a +bx +c +dx +e +f +gx +h +" "\ +3 matches for \"x\" in buffer: *temp* + :a + 2:bx + :c + 4:dx + :e + :f + 7:gx +") + +) + "List of tests for `occur'. +Each element has the format: +\(REGEXP NLINES INPUT-BUFFER-STRING OUTPUT-BUFFER-STRING).") + +(defun test-occur () + (interactive) + (let ((count 1) + failed + (occur-hook nil)) + (dolist (test occur-tests) + (let ((regexp (nth 0 test)) + (nlines (nth 1 test)) + (input-buffer-string (nth 2 test)) + (output-buffer-string (nth 3 test))) + (save-excursion + (with-temp-buffer + (insert input-buffer-string) + (occur regexp nlines) + (unless (equal output-buffer-string + (with-current-buffer "*Occur*" + (buffer-string))) + (setq failed (cons count failed)))))) + (setq count (1+ count))) + (if failed + (message "FAILED TESTS: %S" (reverse failed)) + (message "SUCCESS")))) + +(provide 'occur-testsuite) + +;;; occur-testsuite.el ends here diff --git a/test/redisplay-testsuite.el b/test/redisplay-testsuite.el index 889504c9fa8..c7616fea67d 100644 --- a/test/redisplay-testsuite.el +++ b/test/redisplay-testsuite.el @@ -110,13 +110,72 @@ (propertize "XXX\n" 'face 'highlight) "\n Test: ") (test-insert-overlay "XXX\n" 'mouse-face 'highlight) - (insert "\n")) + (insert "\n\n")) + +(defun test-redisplay-3 () + (insert "Test 3: Overlay with before/after strings and images:\n\n") + (let ((img-data "#define x_width 8 +#define x_height 8 +static unsigned char x_bits[] = {0xff, 0x81, 0xbd, 0xa5, 0xa5, 0xbd, 0x81, 0xff };")) + ;; Control + (insert " Expected: AB" + (propertize "X" 'display `(image :data ,img-data :type xbm)) + "CD\n") + + ;; Overlay with before, after, and image display string. + (insert " Result 1: ") + (let ((opoint (point))) + (insert "AXD\n") + (let ((ov (make-overlay (1+ opoint) (+ 2 opoint)))) + (overlay-put ov 'before-string "B") + (overlay-put ov 'after-string "C") + (overlay-put ov 'display + `(image :data ,img-data :type xbm)))) + + ;; Overlay with before and after string, and image text prop. + (insert " Result 2: ") + (let ((opoint (point))) + (insert "AXD\n") + (let ((ov (make-overlay (1+ opoint) (+ 2 opoint)))) + (overlay-put ov 'before-string "B") + (overlay-put ov 'after-string "C") + (put-text-property (1+ opoint) (+ 2 opoint) 'display + `(image :data ,img-data :type xbm)))) + + ;; Overlays with adjacent before and after strings, and image text + ;; prop. + (insert " Result 3: ") + (let ((opoint (point))) + (insert "AXD\n") + (let ((ov1 (make-overlay opoint (1+ opoint))) + (ov2 (make-overlay (+ 2 opoint) (+ 3 opoint)))) + (overlay-put ov1 'after-string "B") + (overlay-put ov2 'before-string "C") + (put-text-property (1+ opoint) (+ 2 opoint) 'display + `(image :data ,img-data :type xbm)))) + + ;; Three overlays. + (insert " Result 4: ") + (let ((opoint (point))) + (insert "AXD\n\n") + (let ((ov1 (make-overlay opoint (1+ opoint))) + (ov2 (make-overlay (+ 2 opoint) (+ 3 opoint))) + (ov3 (make-overlay (1+ opoint) (+ 2 opoint)))) + (overlay-put ov1 'after-string "B") + (overlay-put ov2 'before-string "C") + (overlay-put ov3 'display `(image :data ,img-data :type xbm)))))) + (defun test-redisplay () (interactive) - (pop-to-buffer (generate-new-buffer "*Redisplay Test*")) - (test-redisplay-1) - (test-redisplay-2) - (goto-char (point-min))) + (let ((buf (get-buffer "*Redisplay Test*"))) + (if buf + (kill-buffer buf)) + (pop-to-buffer (get-buffer-create "*Redisplay Test*")) + (erase-buffer) + (test-redisplay-1) + (test-redisplay-2) + (test-redisplay-3) + (goto-char (point-min)))) ;; arch-tag: fcee53c8-024f-403d-9154-61ae3ce0bfb8 |