Mercurial > hg > xemacs-beta

comparison tests/automated/mule-tests.el @ 4133:5b55fa103aa1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2007-08-21 12:38:57 by aidan] Clean up tests/automated/mule-test.el, fix a problem revealed by it.
author aidan
date Tue, 21 Aug 2007 12:39:15 +0000
parents 4d60c2708e5d
children eded49463f9a
comparison
equal deleted inserted replaced
4132:ebc64fb494fe 4133:5b55fa103aa1
40 ;;----------------------------------------------------------------- 40 ;;-----------------------------------------------------------------
41 41
42 (defun test-chars (&optional for-test-harness) 42 (defun test-chars (&optional for-test-harness)
43 "Insert all characters in a buffer, to see if XEmacs will crash. 43 "Insert all characters in a buffer, to see if XEmacs will crash.
44 This is done by creating a string with all the legal characters 44 This is done by creating a string with all the legal characters
45 in [0, 2^19) range, inserting it into the buffer, and checking 45 in [0, 2^21) range, inserting it into the buffer, and checking
46 that the buffer's contents are equivalent to the string. 46 that the buffer's contents are equivalent to the string.
47 47
48 If FOR-TEST-HARNESS is specified, a temporary buffer is used, and 48 If FOR-TEST-HARNESS is specified, a temporary buffer is used, and
49 the Assert macro checks for correctness." 49 the Assert macro checks for correctness."
50 (let ((max (expt 2 (if (featurep 'mule) 19 8))) 50 (let ((max (expt 2 (if (featurep 'mule) 21 8)))
51 (list nil) 51 (list nil)
52 (i 0)) 52 (i 0))
53 (while (< i max) 53 (while (< i max)
54 (and (not for-test-harness) 54 (and (not for-test-harness)
55 (zerop (% i 1000)) 55 (zerop (% i 1000))
116 ;; Test that revert-buffer resets the modiff 116 ;; Test that revert-buffer resets the modiff
117 ;; Bug reported 2007-06-20 <200706201902.32191.scop@xemacs.org>. 117 ;; Bug reported 2007-06-20 <200706201902.32191.scop@xemacs.org>.
118 ;; Fixed 2007-06-22 <18043.2793.611745.734215@parhasard.net>. 118 ;; Fixed 2007-06-22 <18043.2793.611745.734215@parhasard.net>.
119 ;;---------------------------------------------------------------- 119 ;;----------------------------------------------------------------
120 120
121 ;; #### need a temp file name but this will do for now 121 (let ((test-file-name
122 (let ((test-file-name (expand-file-name "~/test-revert-buffer-resets-modiff")) 122 ;; The Gnus people, when they call #'make-temp-name, then loop,
123 ;; checking if the corresponding file exists. Our #'make-temp-name
124 ;; already does this loop, and the Gnus approach doesn't bring
125 ;; anything; there remains a race condition if you can predict the
126 ;; path name. The path name in question depends on the process ID and
127 ;; a (weak) PRNG seeded with the seconds to the power of the
128 ;; milliseconds of some instant close to the startup time of this
129 ;; XEmacs; without being able to read the address space of this
130 ;; XEmacs, or monitor what stat() calls it does, it is not predictable.
131 ;;
132 ;; The really kosher way to do this is to merge GNU's make-temp-file
133 ;; and use that. It basically has the functionality of the Unix
134 ;; mkstemp.
135 (make-temp-name (expand-file-name "tXfXsKc" (temp-directory))))
123 revert-buffer-function 136 revert-buffer-function
124 kill-buffer-hook) ; paranoia 137 kill-buffer-hook) ; paranoia
125 (find-file test-file-name) 138 (find-file test-file-name)
126 (erase-buffer) 139 (erase-buffer)
127 (insert "a string\n") 140 (insert "a string\n")
128 (save-buffer 0) 141 (Silence-Message (save-buffer 0))
129 (insert "more text\n") 142 (insert "more text\n")
130 (revert-buffer t t) 143 (revert-buffer t t)
131 ;; Just "find-file" with autodetect coding didn't fail for me, but it does 144 ;; Just "find-file" with autodetect coding didn't fail for me, but it does
132 ;; fail under test harness. Still we'll redo the test with an explicit 145 ;; fail under test harness. Still we'll redo the test with an explicit
133 ;; coding system just in case. 146 ;; coding system just in case.
489 (insert-file-contents (locate-data-file "HELLO")) 502 (insert-file-contents (locate-data-file "HELLO"))
490 (Assert (equal 503 (Assert (equal
491 ;; The sort is to make the algorithm of charsets-in-region 504 ;; The sort is to make the algorithm of charsets-in-region
492 ;; irrelevant. 505 ;; irrelevant.
493 (sort (charsets-in-region (point-min) (point-max)) 506 (sort (charsets-in-region (point-min) (point-max))
494 'string<) 507 #'string<)
495 '(arabic-1-column arabic-2-column ascii chinese-big5-1 508 '(arabic-1-column arabic-2-column ascii chinese-big5-1
496 chinese-gb2312 cyrillic-iso8859-5 ethiopic greek-iso8859-7 509 chinese-gb2312 cyrillic-iso8859-5 ethiopic greek-iso8859-7
497 hebrew-iso8859-8 japanese-jisx0208 japanese-jisx0212 510 hebrew-iso8859-8 japanese-jisx0208 japanese-jisx0212
498 katakana-jisx0201 korean-ksc5601 latin-iso8859-1 511 katakana-jisx0201 korean-ksc5601 latin-iso8859-1
499 latin-iso8859-2 thai-xtis vietnamese-viscii-lower))) 512 latin-iso8859-2 thai-xtis vietnamese-viscii-lower)))
500 (Assert (equal 513 (Assert (equal
501 (sort (charsets-in-string (buffer-substring (point-min) 514 (sort (charsets-in-string (buffer-substring (point-min)
502 (point-max))) 515 (point-max)))
503 'string<) 516 #'string<)
504 '(arabic-1-column arabic-2-column ascii chinese-big5-1 517 '(arabic-1-column arabic-2-column ascii chinese-big5-1
505 chinese-gb2312 cyrillic-iso8859-5 ethiopic greek-iso8859-7 518 chinese-gb2312 cyrillic-iso8859-5 ethiopic greek-iso8859-7
506 hebrew-iso8859-8 japanese-jisx0208 japanese-jisx0212 519 hebrew-iso8859-8 japanese-jisx0208 japanese-jisx0212
507 katakana-jisx0201 korean-ksc5601 latin-iso8859-1 520 katakana-jisx0201 korean-ksc5601 latin-iso8859-1
508 latin-iso8859-2 thai-xtis vietnamese-viscii-lower)))) 521 latin-iso8859-2 thai-xtis vietnamese-viscii-lower))))
509 522
510 ;; Language environments. 523 ;;---------------------------------------------------------------
511 (dolist (language (mapcar 'car language-info-alist)) 524 ;; Language environments, and whether the specified values are sane.
512 (set-language-environment language) 525 ;;---------------------------------------------------------------
526 (loop
527 for language in (mapcar #'car language-info-alist)
528 with language-input-method = nil
529 do
530 ;; s-l-e can call #'require, which says "Loading ..."
531 (Silence-Message (set-language-environment language))
513 (Assert (equal language current-language-environment)) 532 (Assert (equal language current-language-environment))
514 (set-input-method (get-language-info language 'input-method)) 533
515 (Assert (equal (get-language-info language 'input-method) 534 (setq language-input-method
516 current-input-method)) 535 (get-language-info language 'input-method))
536 (when (and language-input-method
537 ;; #### Not robust, if more input methods besides canna are
538 ;; in core. The intention of this is that if *any* of the
539 ;; packages' input methods are available, we check that *all*
540 ;; of the language environments' input methods actually
541 ;; exist, which goes against the spirit of non-monolithic
542 ;; packages. But I don't have a better approach to this.
543 (> (length input-method-alist) 1))
544 (Assert (assoc language-input-method input-method-alist))
545 (Skip-Test-Unless
546 (assoc language-input-method input-method-alist)
547 "input method unavailable"
548 (format "check that IM %s can be activated" language-input-method)
549 ;; s-i-m can load files.
550 (Silence-Message
551 (set-input-method language-input-method))
552 (Assert (equal language-input-method current-input-method))))
553
517 (dolist (charset (get-language-info language 'charset)) 554 (dolist (charset (get-language-info language 'charset))
518 (Assert (charsetp (find-charset charset)))) 555 (Assert (charsetp (find-charset charset))))
519 (dolist (coding-system (get-language-info language 'coding-system)) 556 (dolist (coding-system (get-language-info language 'coding-system))
520 (Assert (coding-system-p (find-coding-system coding-system)))) 557 (Assert (coding-system-p (find-coding-system coding-system))))
521 (dolist (coding-system (get-language-info language 'coding-system)) 558 (dolist (coding-system (get-language-info language
522 (Assert (coding-system-p (find-coding-system coding-system))))) 559 'native-coding-system))
560 ;; We don't have the appropriate POSIX locales to test with a
561 ;; native-coding-system that is a function.
562 (unless (functionp coding-system)
563 (Assert (coding-system-p (find-coding-system coding-system))))))
523 564
524 (with-temp-buffer 565 (with-temp-buffer
525 (flet 566 (flet
526 ((Assert-elc-is-escape-quoted () 567 ((Assert-elc-is-escape-quoted ()
527 "Assert the current buffer has an escape-quoted cookie if compiled." 568 "Assert the current buffer has an escape-quoted cookie if compiled."
533 (temp-directory))))) 574 (temp-directory)))))
534 (byte-compile-insert-header 575 (byte-compile-insert-header
535 temporary-file-name 576 temporary-file-name
536 (current-buffer) 577 (current-buffer)
537 byte-compile-result) 578 byte-compile-result)
538 (Assert (string-match "^;;;###coding system: escape-quoted" 579 (Assert (string-match
539 (buffer-substring nil nil 580 "^;;;###coding system: escape-quoted"
540 byte-compile-result)))))) 581 (buffer-substring nil nil byte-compile-result))))))
541 (Assert-elc-has-no-specified-encoding () 582 (Assert-elc-has-no-specified-encoding ()
542 "Assert the current buffer has no coding cookie if compiled." 583 "Assert the current buffer has no coding cookie if compiled."
543 (save-excursion 584 (save-excursion
544 (let ((byte-compile-result (byte-compile-from-buffer 585 (let ((byte-compile-result (byte-compile-from-buffer
545 (current-buffer) nil nil)) 586 (current-buffer) nil nil))
550 temporary-file-name 591 temporary-file-name
551 (current-buffer) 592 (current-buffer)
552 byte-compile-result) 593 byte-compile-result)
553 (Assert (not (string-match 594 (Assert (not (string-match
554 ";;;###coding system:" 595 ";;;###coding system:"
555 (buffer-substring nil nil byte-compile-result)))))))) 596 (buffer-substring nil nil
597 byte-compile-result))))))))
556 (insert 598 (insert
557 ;; Create a buffer creating the Unicode escapes. 599 ;; Create a buffer with Unicode escapes. The #'read call is at
558 #r" (defvar testing-mule-compilation-handling 600 ;; runtime, because this file may be compiled and read in a non-Mule
559 (string ?\u371E ;; kDefinition beautiful; pretty, used 601 ;; XEmacs. (But it won't be run.)
602 (read
603 "#r\" (defvar testing-mule-compilation-handling
604 (string ?\\u371E ;; kDefinition beautiful; pretty, used
560 ;; in girl's name 605 ;; in girl's name
561 ?\U0002A6A9 ;; kDefinition (Cant.) sound of shouting 606 ?\\U0002A6A9 ;; kDefinition (Cant.) sound of shouting
562 ?\U0002A65B ;; kDefinition (Cant.) decayed teeth; 607 ?\\U0002A65B ;; kDefinition (Cant.) decayed teeth;
563 ;; tongue-tied 608 ;; tongue-tied
564 ?\U00010400 ;; DESERET CAPITAL LETTER LONG I 609 ?\\U00010400 ;; DESERET CAPITAL LETTER LONG I
565 ?\u3263)) ;; CIRCLED HANGUL RIEUL ") 610 ?\\u3263)) ;; CIRCLED HANGUL RIEUL \""))
566 611
567 (Assert-elc-is-escape-quoted) 612 (Assert-elc-is-escape-quoted)
568 (delete-region (point-min) (point-max)) 613 (delete-region (point-min) (point-max))
569 614
570 (insert 615 (insert
571 ;; This time, the buffer will contain the actual characters, because of 616 ;; This time, the buffer will contain the actual characters, because of
572 ;; u flag to the #r. 617 ;; u flag to the #r.
573 #ru" (defvar testing-mule-compilation-handling 618 (read
574 (string ?\u371E ;; kDefinition beautiful; pretty, used 619 "#ru\" (defvar testing-mule-compilation-handling
620 (string ?\\u371E ;; kDefinition beautiful; pretty, used
575 ;; in girl's name 621 ;; in girl's name
576 ?\U0002A6A9 ;; kDefinition (Cant.) sound of shouting 622 ?\\U0002A6A9 ;; kDefinition (Cant.) sound of shouting
577 ?\U0002A65B ;; kDefinition (Cant.) decayed teeth; 623 ?\\U0002A65B ;; kDefinition (Cant.) decayed teeth;
578 ;; tongue-tied 624 ;; tongue-tied
579 ?\U00010400 ;; DESERET CAPITAL LETTER LONG I 625 ?\\U00010400 ;; DESERET CAPITAL LETTER LONG I
580 ?\u3263)) ;; CIRCLED HANGUL RIEUL ") 626 ?\\u3263)) ;; CIRCLED HANGUL RIEUL \""))
581 627
582 (Assert-elc-is-escape-quoted) 628 (Assert-elc-is-escape-quoted)
583 (delete-region (point-min) (point-max)) 629 (delete-region (point-min) (point-max))
584 630
585 (insert 631 (insert
586 ;; Just a single four character escape. 632 ;; Just a single four character escape.
587 #r" (defvar testing-mule-compilation-handling 633 (read
588 (string ?\u371E)) ;; kDefinition beautiful; pretty, used") 634 "#r\" (defvar testing-mule-compilation-handling
635 (string ?\\u371E)) ;; kDefinition beautiful; pretty, used\""))
589 636
590 (Assert-elc-is-escape-quoted) 637 (Assert-elc-is-escape-quoted)
591 (delete-region (point-min) (point-max)) 638 (delete-region (point-min) (point-max))
592 639
593 (insert 640 (insert
594 ;; Just a single eight character escape. 641 ;; Just a single eight character escape.
595 #r" (defvar testing-mule-compilation-handling 642 (read
596 (string ?\U0002A65B)) ;; kDefinition (Cant.) decayed teeth;") 643 "#r\" (defvar testing-mule-compilation-handling
644 (string ?\\U0002A65B)) ;; kDefinition (Cant.) decayed teeth;\""))
597 645
598 (Assert-elc-is-escape-quoted) 646 (Assert-elc-is-escape-quoted)
599 (delete-region (point-min) (point-max)) 647 (delete-region (point-min) (point-max))
600 648
601 (insert 649 (insert
602 ;; A single latin-1 hex digit escape 650 ;; A single latin-1 hex digit escape No run-time #'read call,
651 ;; non-Mule can handle this too.
603 #r" (defvar testing-mule-compilation-handling 652 #r" (defvar testing-mule-compilation-handling
604 (string ?\xab)) ;; LEFT-POINTING DOUBLE ANGLE QUOTATION MARK") 653 (string ?\xab)) ;; LEFT-POINTING DOUBLE ANGLE QUOTATION MARK")
605 654
606 (Assert-elc-has-no-specified-encoding) 655 (Assert-elc-has-no-specified-encoding)
607 (delete-region (point-min) (point-max)) 656 (delete-region (point-min) (point-max))
608 657
609 (insert 658 (insert
610 ;; A single latin-1 character 659 ;; A single latin-1 character. No run-time #'read call.
611 #ru" (defvar testing-mule-compilation-handling 660 #ru" (defvar testing-mule-compilation-handling
612 (string ?\u00AB)) ;; LEFT-POINTING DOUBLE ANGLE QUOTATION MARK") 661 (string ?\u00AB)) ;; LEFT-POINTING DOUBLE ANGLE QUOTATION MARK\")")
613 662
614 (Assert-elc-has-no-specified-encoding) 663 (Assert-elc-has-no-specified-encoding)
615 (delete-region (point-min) (point-max)) 664 (delete-region (point-min) (point-max))
616 665
617 (insert 666 (insert
618 ;; Just ASCII. 667 ;; Just ASCII. No run-time #'read call
619 #r" (defvar testing-mule-compilation-handling 668 #r" (defvar testing-mule-compilation-handling
620 (string ?A)) ;; LATIN CAPITAL LETTER A") 669 (string ?A)) ;; LATIN CAPITAL LETTER A")
621 670
622 (Assert-elc-has-no-specified-encoding) 671 (Assert-elc-has-no-specified-encoding)
672 (delete-region (point-min) (point-max))
673
674 ;; This bug exists because the coding-cookie insertion code looks at
675 ;; the input buffer, not the output buffer.
676 ;;
677 ;; It looks at the input buffer because byte-compile-dynamic and
678 ;; byte-compile-dynamic-docstrings currently need to be
679 ;; unconditionally turned off for Mule files, since dynamic
680 ;; compilation of function bodies and docstrings fails if you can't
681 ;; call (point) and trivially get the byte offset in the file.
682 ;;
683 ;; And to unconditionally turn those two features off, you need to
684 ;; know before byte-compilation whether the byte-compilation output
685 ;; file contains non-Latin-1 characters, or perhaps to check after
686 ;; compilation and redo; but we don't do the latter.
687 ;;
688 ;; To fix this bug, we need to add Mule support to
689 ;; byte-compile-dynamic and byte-compile-dynamic-docstrings. Or drop
690 ;; support for those features entirely.
691 (insert
692 "(defvar testing-mule-compilation-handling (eval-when-compile
693 (decode-char 'ucs #x371e))) ;; kDefinition beautiful; pretty, used\"")
694 (Known-Bug-Expect-Failure
695 (Assert-elc-is-escape-quoted))
623 (delete-region (point-min) (point-max)))) 696 (delete-region (point-min) (point-max))))
624 ) 697 )