code.delx.au - gnu-emacs-elpa/blob - packages/realgud/test/test-regexp-perldb.el

   1 (require 'test-simple)
   2 (load-file "../realgud/common/buffer/command.el")
   3 (load-file "../realgud/lang/perl.el")
   4 (load-file "../realgud/debugger/perldb/init.el")
   5 (load-file "./regexp-helper.el")
   6
   7 (declare-function __FILE__              'load-relative)
   8 (declare-function prompt-match          'regexp-helper)
   9 (declare-function cmdbuf-loc-match      'realgud-regexp)
  10
  11 (test-simple-start)
  12
  13 (eval-when-compile
  14   (defvar dbg-name)
  15   (defvar realgud:perldb-pat-hash)
  16   (defvar realgud-pat-hash)
  17   (defvar panic-tb)
  18   (defvar loc-pat)
  19   (defvar test-pos)
  20   (defvar prompt-pat)
  21   (defvar test-dbgr)
  22   (defvar carp-bt-re)
  23   (defvar file-group)
  24   (defvar line-group)
  25   (defvar test-text)
  26   (defvar lang-bt-pat)
  27   (defvar lang-bt-re)
  28   (defvar realgud-bt-pat)
  29   (defvar realgud-bt-re)
  30   (defvar test-s1)
  31   (defvar realgud-perl-ignore-file-re)
  32 )
  33
  34 ; Some setup usually done in setting up the buffer.
  35 ; We customize this for this debugger.
  36 ; FIXME: encapsulate this.
  37 (setq dbg-name "perldb")
  38 (set (make-local-variable 'loc-pat)
  39      (gethash "loc"    (gethash dbg-name realgud-pat-hash)))
  40 (set (make-local-variable 'prompt-pat)
  41      (gethash "prompt" realgud:perldb-pat-hash))
  42
  43 (setq test-dbgr (make-realgud-cmdbuf-info
  44                  :debugger-name dbg-name
  45                  :loc-regexp (realgud-loc-pat-regexp loc-pat)
  46                  :file-group (realgud-loc-pat-file-group loc-pat)
  47                  :line-group (realgud-loc-pat-line-group loc-pat)
  48                  :text-group (realgud-loc-pat-text-group loc-pat)
  49                  ))
  50
  51 (note "prompt")
  52 (prompt-match "  DB<2> "  "2")
  53 (prompt-match "[pid=6489->6502]  DB<1> " "1")
  54
  55 (assert-equal 0 (string-match realgud-perl-ignore-file-re
  56                               "(eval 1006)[../example/eval.pl:5]")
  57               "perldb file ignore matching")
  58
  59 (setq test-text "main::(/usr/bin/latex2html:102):")
  60
  61 (assert-t (numberp (cmdbuf-loc-match test-text test-dbgr)) "basic location")
  62 (assert-equal "/usr/bin/latex2html"
  63               (match-string (realgud-cmdbuf-info-file-group test-dbgr)
  64                             test-text)
  65               "extract file name")
  66
  67 (setq test-text "File::Basename::dirname(/usr/share/perl/5.16.0/File/Basename.pm:284):
  68 284:        my $path = shift;
  69 ")
  70
  71 (assert-t (numberp (cmdbuf-loc-match test-text test-dbgr))
  72           "location with source")
  73 (assert-equal "/usr/share/perl/5.16.0/File/Basename.pm"
  74               (match-string (realgud-cmdbuf-info-file-group test-dbgr)
  75                             test-text)
  76               "extract file name when we have source text")
  77 (assert-equal "284"
  78               (match-string (realgud-cmdbuf-info-line-group test-dbgr)
  79                             test-text)
  80               "extract line number when we have source text")
  81 (assert-equal "    my $path = shift;"
  82               (match-string (realgud-cmdbuf-info-text-group test-dbgr)
  83                             test-text)
  84               "extract source text")
  85
  86 (setq test-text "main::((eval 6)[eval.pl:5]:2): $x = 2;")
  87
  88 (assert-t (numberp (cmdbuf-loc-match test-text test-dbgr)) "eval location")
  89 (assert-equal "(eval 6)[eval.pl:5]"
  90               (match-string (realgud-cmdbuf-info-file-group test-dbgr)
  91                             test-text)
  92               "extract file name")
  93
  94 (assert-equal "2"
  95               (match-string (realgud-cmdbuf-info-line-group test-dbgr)
  96                             test-text) "extract line number")
  97
  98 (note "location for with CODE in it")
  99 (setq test-text "main::CODE(0x9407ac8)(l2hconf.pm:6):")
 100 (assert-t (numberp (cmdbuf-loc-match test-text test-dbgr)))
 101 (assert-equal "l2hconf.pm"
 102               (match-string (realgud-cmdbuf-info-file-group test-dbgr)
 103                             test-text))
 104 (assert-equal "6"
 105               (match-string (realgud-cmdbuf-info-line-group test-dbgr)
 106                             test-text))
 107
 108 (note "debugger-backtrace")
 109 (setq realgud-bt-pat  (gethash "debugger-backtrace"
 110                             realgud:perldb-pat-hash))
 111 (setq test-s1
 112       "$ = main::top_navigation_panel called from file `./latex2html' line 7400
 113 p")
 114 (setq realgud-bt-re (realgud-loc-pat-regexp realgud-bt-pat))
 115 (setq file-group (realgud-loc-pat-file-group realgud-bt-pat))
 116 (setq line-group (realgud-loc-pat-line-group realgud-bt-pat))
 117 (assert-equal 30 (string-match realgud-bt-re test-s1))
 118 (assert-equal "./latex2html"
 119               (substring test-s1
 120                          (match-beginning file-group)
 121                          (match-end file-group)))
 122 (assert-equal "7400"
 123               (substring test-s1
 124                          (match-beginning line-group)
 125                          (match-end line-group)))
 126
 127 (note "debugger-errmsg")
 128 (setq realgud-bt-pat  (gethash "perl-errmsg"
 129                             realgud:perldb-pat-hash))
 130 (setq test-s1
 131       "Use of uninitialized value $lines[0] in join or string at bin/../lib/LineCache.pm line 548.")
 132 (setq realgud-bt-re (realgud-loc-pat-regexp realgud-bt-pat))
 133 (setq file-group (realgud-loc-pat-file-group realgud-bt-pat))
 134 (setq line-group (realgud-loc-pat-line-group realgud-bt-pat))
 135 (assert-equal 54 (string-match realgud-bt-re test-s1))
 136 (assert-equal "bin/../lib/LineCache.pm"
 137               (substring test-s1
 138                          (match-beginning file-group)
 139                          (match-end file-group)))
 140 (assert-equal "548"
 141               (substring test-s1
 142                          (match-beginning line-group)
 143                          (match-end line-group)))
 144
 145 (note "carp-backtrace")
 146 (setq test-s1
 147       " at /tmp/foo.pl line 7
 148         main::__ANON__('Illegal division by zero at /tmp/foo.pl line 4.\x{a}') called at foo2.pl line 5
 149         main::foo(3) called at foo3.pl line 8
 150 ")
 151 (setq lang-bt-pat (gethash "lang-backtrace"
 152                            realgud:perldb-pat-hash))
 153 (setq carp-bt-re (realgud-loc-pat-regexp lang-bt-pat))
 154 (setq file-group (realgud-loc-pat-file-group lang-bt-pat))
 155 (setq line-group (realgud-loc-pat-line-group lang-bt-pat))
 156 (assert-equal 0 (string-match carp-bt-re test-s1))
 157 (assert-equal "/tmp/foo.pl"
 158               (substring test-s1
 159                          (match-beginning file-group)
 160                          (match-end file-group)))
 161 (assert-equal "7"
 162               (substring test-s1
 163                          (match-beginning line-group)
 164                          (match-end line-group)))
 165 (setq test-pos (match-end 0))
 166
 167 (assert-equal 22 (string-match carp-bt-re test-s1 test-pos))
 168 (assert-equal "foo2.pl"
 169               (substring test-s1
 170                          (match-beginning file-group)
 171                          (match-end file-group)))
 172 (assert-equal "5"
 173               (substring test-s1
 174                          (match-beginning line-group)
 175                          (match-end line-group)))
 176
 177 (setq test-pos (match-end 0))
 178 (assert-equal 119 (string-match carp-bt-re test-s1 test-pos))
 179 (assert-equal "foo3.pl"
 180               (substring test-s1
 181                          (match-beginning file-group)
 182                          (match-end file-group)))
 183 (assert-equal "8"
 184               (substring test-s1
 185                          (match-beginning line-group)
 186                          (match-end line-group)))
 187
 188 (end-tests)