/[pcre]/code/trunk/perltest.pl
ViewVC logotype

Contents of /code/trunk/perltest.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 97 - (show annotations) (download)
Mon Mar 5 12:36:47 2007 UTC (7 years, 1 month ago) by ph10
File MIME type: text/plain
File size: 4816 byte(s)
Applied Bob and Daniel's patches to convert the build system to automake. Added 
the maintain directory, containing files that are used for maintenance, but are 
not distributed. This is an intermediate step.

1 #! /usr/bin/env perl
2
3 # Program for testing regular expressions with perl to check that PCRE handles
4 # them the same. This is the version that supports /8 for UTF-8 testing. As it
5 # stands, it requires at least Perl 5.8 for UTF-8 support. However, it needs to
6 # have "use utf8" at the start for running the UTF-8 tests, but *not* for the
7 # other tests. The only way I've found for doing this is to cat this line in
8 # explicitly in the RunPerlTest script.
9
10 # use locale; # With this included, \x0b matches \s!
11
12 # Function for turning a string into a string of printing chars. There are
13 # currently problems with UTF-8 strings; this fudges round them.
14
15 sub pchars {
16 my($t) = "";
17
18 if ($utf8)
19 {
20 @p = unpack('U*', $_[0]);
21 foreach $c (@p)
22 {
23 if ($c >= 32 && $c < 127) { $t .= chr $c; }
24 else { $t .= sprintf("\\x{%02x}", $c); }
25 }
26 }
27
28 else
29 {
30 foreach $c (split(//, $_[0]))
31 {
32 if (ord $c >= 32 && ord $c < 127) { $t .= $c; }
33 else { $t .= sprintf("\\x%02x", ord $c); }
34 }
35 }
36
37 $t;
38 }
39
40
41 # Read lines from named file or stdin and write to named file or stdout; lines
42 # consist of a regular expression, in delimiters and optionally followed by
43 # options, followed by a set of test data, terminated by an empty line.
44
45 # Sort out the input and output files
46
47 if (@ARGV > 0)
48 {
49 open(INFILE, "<$ARGV[0]") || die "Failed to open $ARGV[0]\n";
50 $infile = "INFILE";
51 }
52 else { $infile = "STDIN"; }
53
54 if (@ARGV > 1)
55 {
56 open(OUTFILE, ">$ARGV[1]") || die "Failed to open $ARGV[1]\n";
57 $outfile = "OUTFILE";
58 }
59 else { $outfile = "STDOUT"; }
60
61 printf($outfile "Perl $] Regular Expressions\n\n");
62
63 # Main loop
64
65 NEXT_RE:
66 for (;;)
67 {
68 printf " re> " if $infile eq "STDIN";
69 last if ! ($_ = <$infile>);
70 printf $outfile "$_" if $infile ne "STDIN";
71 next if ($_ eq "");
72
73 $pattern = $_;
74
75 while ($pattern !~ /^\s*(.).*\1/s)
76 {
77 printf " > " if $infile eq "STDIN";
78 last if ! ($_ = <$infile>);
79 printf $outfile "$_" if $infile ne "STDIN";
80 $pattern .= $_;
81 }
82
83 chomp($pattern);
84 $pattern =~ s/\s+$//;
85
86 # The private /+ modifier means "print $' afterwards".
87
88 $showrest = ($pattern =~ s/\+(?=[a-z]*$)//);
89
90 # Remove /8 from a UTF-8 pattern.
91
92 $utf8 = $pattern =~ s/8(?=[a-z]*$)//;
93
94 # Check that the pattern is valid
95
96 eval "\$_ =~ ${pattern}";
97 if ($@)
98 {
99 printf $outfile "Error: $@";
100 next NEXT_RE;
101 }
102
103 # If the /g modifier is present, we want to put a loop round the matching;
104 # otherwise just a single "if".
105
106 $cmd = ($pattern =~ /g[a-z]*$/)? "while" : "if";
107
108 # If the pattern is actually the null string, Perl uses the most recently
109 # executed (and successfully compiled) regex is used instead. This is a
110 # nasty trap for the unwary! The PCRE test suite does contain null strings
111 # in places - if they are allowed through here all sorts of weird and
112 # unexpected effects happen. To avoid this, we replace such patterns with
113 # a non-null pattern that has the same effect.
114
115 $pattern = "/(?#)/$2" if ($pattern =~ /^(.)\1(.*)$/);
116
117 # Read data lines and test them
118
119 for (;;)
120 {
121 printf "data> " if $infile eq "STDIN";
122 last NEXT_RE if ! ($_ = <$infile>);
123 chomp;
124 printf $outfile "$_\n" if $infile ne "STDIN";
125
126 s/\s+$//;
127 s/^\s+//;
128
129 last if ($_ eq "");
130 $x = eval "\"$_\""; # To get escapes processed
131
132 # Empty array for holding results, then do the matching.
133
134 @subs = ();
135
136 $pushes = "push \@subs,\$&;" .
137 "push \@subs,\$1;" .
138 "push \@subs,\$2;" .
139 "push \@subs,\$3;" .
140 "push \@subs,\$4;" .
141 "push \@subs,\$5;" .
142 "push \@subs,\$6;" .
143 "push \@subs,\$7;" .
144 "push \@subs,\$8;" .
145 "push \@subs,\$9;" .
146 "push \@subs,\$10;" .
147 "push \@subs,\$11;" .
148 "push \@subs,\$12;" .
149 "push \@subs,\$13;" .
150 "push \@subs,\$14;" .
151 "push \@subs,\$15;" .
152 "push \@subs,\$16;" .
153 "push \@subs,\$'; }";
154
155 eval "${cmd} (\$x =~ ${pattern}) {" . $pushes;
156
157 if ($@)
158 {
159 printf $outfile "Error: $@\n";
160 next NEXT_RE;
161 }
162 elsif (scalar(@subs) == 0)
163 {
164 printf $outfile "No match\n";
165 }
166 else
167 {
168 while (scalar(@subs) != 0)
169 {
170 printf $outfile (" 0: %s\n", &pchars($subs[0]));
171 printf $outfile (" 0+ %s\n", &pchars($subs[17])) if $showrest;
172 $last_printed = 0;
173 for ($i = 1; $i <= 16; $i++)
174 {
175 if (defined $subs[$i])
176 {
177 while ($last_printed++ < $i-1)
178 { printf $outfile ("%2d: <unset>\n", $last_printed); }
179 printf $outfile ("%2d: %s\n", $i, &pchars($subs[$i]));
180 $last_printed = $i;
181 }
182 }
183 splice(@subs, 0, 18);
184 }
185 }
186 }
187 }
188
189 # printf $outfile "\n";
190
191 # End

Properties

Name Value
svn:executable *

webmaster@exim.org
ViewVC Help
Powered by ViewVC 1.1.12