← Back to branch summary

~ubuntu-branches/ubuntu/feisty/apache2/feisty-updates

« back to all changes in this revision

Viewing changes to srclib/pcre/perltest

  • Committer: Bazaar Package Importer
  • Author(s): Andreas Barth
  • Date: 2006-12-09 21:05:45 UTC
  • mfrom: (0.6.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20061209210545-h70s0xaqc2v8vqr2
Tags: 2.2.3-3.2
http://bugs.debian.org/396265
* Non-maintainer upload.
* 043_ajp_connection_reuse: Patch from upstream Bugzilla, fixing a critical
  issue with regard to connection reuse in mod_proxy_ajp.
  Closes: #396265

Show diffs side-by-side

added added

removed removed

Lines of Context:
srclib/pcre/perltest
 
1
#! /usr/bin/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. For Perl 5.6, it
 
6
# can be used as is for non-UTF-8 testing, but you have to uncomment the
 
7
# "use utf8" lines in order to to UTF-8 stuff (and you mustn't uncomment them
 
8
# for non-UTF-8 use).
 
9
 
 
10
 
 
11
# Function for turning a string into a string of printing chars. There are
 
12
# currently problems with UTF-8 strings; this fudges round them.
 
13
 
 
14
sub pchars {
 
15
my($t) = "";
 
16
 
 
17
if ($utf8)
 
18
  {
 
19
#  use utf8;                    <=============== For UTF-8 in Perl 5.6
 
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
 
 
42
# Read lines from named file or stdin and write to named file or stdout; lines
 
43
# consist of a regular expression, in delimiters and optionally followed by
 
44
# options, followed by a set of test data, terminated by an empty line.
 
45
 
 
46
# Sort out the input and output files
 
47
 
 
48
if (@ARGV > 0)
 
49
  {
 
50
  open(INFILE, "<$ARGV[0]") || die "Failed to open $ARGV[0]\n";
 
51
  $infile = "INFILE";
 
52
  }
 
53
else { $infile = "STDIN"; }
 
54
 
 
55
if (@ARGV > 1)
 
56
  {
 
57
  open(OUTFILE, ">$ARGV[1]") || die "Failed to open $ARGV[1]\n";
 
58
  $outfile = "OUTFILE";
 
59
  }
 
60
else { $outfile = "STDOUT"; }
 
61
 
 
62
printf($outfile "Perl $] Regular Expressions\n\n");
 
63
 
 
64
# Main loop
 
65
 
 
66
NEXT_RE:
 
67
for (;;)
 
68
  {
 
69
  printf "  re> " if $infile eq "STDIN";
 
70
  last if ! ($_ = <$infile>);
 
71
  printf $outfile "$_" if $infile ne "STDIN";
 
72
  next if ($_ eq "");
 
73
 
 
74
  $pattern = $_;
 
75
 
 
76
  while ($pattern !~ /^\s*(.).*\1/s)
 
77
    {
 
78
    printf "    > " if $infile eq "STDIN";
 
79
    last if ! ($_ = <$infile>);
 
80
    printf $outfile "$_" if $infile ne "STDIN";
 
81
    $pattern .= $_;
 
82
    }
 
83
 
 
84
   chomp($pattern);
 
85
   $pattern =~ s/\s+$//;
 
86
 
 
87
  # The private /+ modifier means "print $' afterwards".
 
88
 
 
89
  $showrest = ($pattern =~ s/\+(?=[a-z]*$)//);
 
90
 
 
91
  # The private /8 modifier means "operate in UTF-8". Currently, Perl
 
92
  # has bugs that we try to work around using this flag.
 
93
 
 
94
  $utf8 = ($pattern =~ s/8(?=[a-z]*$)//);
 
95
 
 
96
  # Check that the pattern is valid
 
97
 
 
98
  if ($utf8)
 
99
    {
 
100
#    use utf8;                    <=============== For UTF-8 in Perl 5.6
 
101
    eval "\$_ =~ ${pattern}";
 
102
    }
 
103
  else
 
104
    {
 
105
    eval "\$_ =~ ${pattern}";
 
106
    }
 
107
 
 
108
  if ($@)
 
109
    {
 
110
    printf $outfile "Error: $@";
 
111
    next NEXT_RE;
 
112
    }
 
113
 
 
114
  # If the /g modifier is present, we want to put a loop round the matching;
 
115
  # otherwise just a single "if".
 
116
 
 
117
  $cmd = ($pattern =~ /g[a-z]*$/)? "while" : "if";
 
118
 
 
119
  # If the pattern is actually the null string, Perl uses the most recently
 
120
  # executed (and successfully compiled) regex is used instead. This is a
 
121
  # nasty trap for the unwary! The PCRE test suite does contain null strings
 
122
  # in places - if they are allowed through here all sorts of weird and
 
123
  # unexpected effects happen. To avoid this, we replace such patterns with
 
124
  # a non-null pattern that has the same effect.
 
125
 
 
126
  $pattern = "/(?#)/$2" if ($pattern =~ /^(.)\1(.*)$/);
 
127
 
 
128
  # Read data lines and test them
 
129
 
 
130
  for (;;)
 
131
    {
 
132
    printf "data> " if $infile eq "STDIN";
 
133
    last NEXT_RE if ! ($_ = <$infile>);
 
134
    chomp;
 
135
    printf $outfile "$_\n" if $infile ne "STDIN";
 
136
 
 
137
    s/\s+$//;
 
138
    s/^\s+//;
 
139
 
 
140
    last if ($_ eq "");
 
141
 
 
142
    $x = eval "\"$_\"";   # To get escapes processed
 
143
 
 
144
    # Empty array for holding results, then do the matching.
 
145
 
 
146
    @subs = ();
 
147
 
 
148
    $pushes = "push \@subs,\$&;" .
 
149
         "push \@subs,\$1;" .
 
150
         "push \@subs,\$2;" .
 
151
         "push \@subs,\$3;" .
 
152
         "push \@subs,\$4;" .
 
153
         "push \@subs,\$5;" .
 
154
         "push \@subs,\$6;" .
 
155
         "push \@subs,\$7;" .
 
156
         "push \@subs,\$8;" .
 
157
         "push \@subs,\$9;" .
 
158
         "push \@subs,\$10;" .
 
159
         "push \@subs,\$11;" .
 
160
         "push \@subs,\$12;" .
 
161
         "push \@subs,\$13;" .
 
162
         "push \@subs,\$14;" .
 
163
         "push \@subs,\$15;" .
 
164
         "push \@subs,\$16;" .
 
165
         "push \@subs,\$'; }";
 
166
 
 
167
    if ($utf8)
 
168
      {
 
169
#      use utf8;                    <=============== For UTF-8 in Perl 5.6
 
170
      eval "${cmd} (\$x =~ ${pattern}) {" . $pushes;
 
171
      }
 
172
    else
 
173
      {
 
174
      eval "${cmd} (\$x =~ ${pattern}) {" . $pushes;
 
175
      }
 
176
 
 
177
    if ($@)
 
178
      {
 
179
      printf $outfile "Error: $@\n";
 
180
      next NEXT_RE;
 
181
      }
 
182
    elsif (scalar(@subs) == 0)
 
183
      {
 
184
      printf $outfile "No match\n";
 
185
      }
 
186
    else
 
187
      {
 
188
      while (scalar(@subs) != 0)
 
189
        {
 
190
        printf $outfile (" 0: %s\n", &pchars($subs[0]));
 
191
        printf $outfile (" 0+ %s\n", &pchars($subs[17])) if $showrest;
 
192
        $last_printed = 0;
 
193
        for ($i = 1; $i <= 16; $i++)
 
194
          {
 
195
          if (defined $subs[$i])
 
196
            {
 
197
            while ($last_printed++ < $i-1)
 
198
              { printf $outfile ("%2d: <unset>\n", $last_printed); }
 
199
            printf $outfile ("%2d: %s\n", $i, &pchars($subs[$i]));
 
200
            $last_printed = $i;
 
201
            }
 
202
          }
 
203
        splice(@subs, 0, 18);
 
204
        }
 
205
      }
 
206
    }
 
207
  }
 
208
 
 
209
# printf $outfile "\n";
 
210
 
 
211
# End