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

Contents of /code/trunk/perltest.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 97 - (hide annotations) (download)
Mon Mar 5 12:36:47 2007 UTC (7 years, 6 months 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 ph10 97 #! /usr/bin/env perl
2 nigel 3
3     # Program for testing regular expressions with perl to check that PCRE handles
4 nigel 63 # them the same. This is the version that supports /8 for UTF-8 testing. As it
5 nigel 91 # 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 nigel 3
10 nigel 91 # use locale; # With this included, \x0b matches \s!
11 nigel 3
12 nigel 63 # 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 nigel 3
15     sub pchars {
16     my($t) = "";
17    
18 nigel 63 if ($utf8)
19 nigel 3 {
20 nigel 63 @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 nigel 3 }
27 nigel 63
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 nigel 3 $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 nigel 23 printf($outfile "Perl $] Regular Expressions\n\n");
62 nigel 3
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 nigel 63 # The private /+ modifier means "print $' afterwards".
87 nigel 41
88     $showrest = ($pattern =~ s/\+(?=[a-z]*$)//);
89    
90 nigel 91 # Remove /8 from a UTF-8 pattern.
91 nigel 63
92 nigel 91 $utf8 = $pattern =~ s/8(?=[a-z]*$)//;
93 nigel 63
94 nigel 3 # Check that the pattern is valid
95    
96 nigel 91 eval "\$_ =~ ${pattern}";
97 nigel 3 if ($@)
98     {
99 nigel 23 printf $outfile "Error: $@";
100 nigel 3 next NEXT_RE;
101     }
102    
103 nigel 41 # 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 nigel 3 # 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 nigel 41 $x = eval "\"$_\""; # To get escapes processed
131 nigel 3
132 nigel 41 # Empty array for holding results, then do the matching.
133 nigel 3
134 nigel 41 @subs = ();
135    
136 nigel 63 $pushes = "push \@subs,\$&;" .
137 nigel 41 "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 nigel 91 eval "${cmd} (\$x =~ ${pattern}) {" . $pushes;
156 nigel 63
157 nigel 3 if ($@)
158     {
159     printf $outfile "Error: $@\n";
160     next NEXT_RE;
161     }
162 nigel 41 elsif (scalar(@subs) == 0)
163 nigel 3 {
164     printf $outfile "No match\n";
165     }
166     else
167     {
168 nigel 41 while (scalar(@subs) != 0)
169 nigel 3 {
170 nigel 41 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 nigel 3 {
175 nigel 41 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 nigel 3 }
183 nigel 41 splice(@subs, 0, 18);
184 nigel 3 }
185     }
186     }
187     }
188    
189 nigel 75 # printf $outfile "\n";
190 nigel 3
191     # End

Properties

Name Value
svn:executable *

webmaster@exim.org
ViewVC Help
Powered by ViewVC 1.1.12