"Fossies" - the Fresh Open Source Software Archive

Member "pcre2-10.36/perltest.sh" (13 Sep 2020, 11365 Bytes) of package /linux/misc/pcre2-10.36.tar.bz2:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Bash source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "perltest.sh": 10.35_vs_10.36.

    1 #! /bin/sh
    2 
    3 # Script for testing regular expressions with perl to check that PCRE2 handles
    4 # them the same. For testing with different versions of Perl, if the first
    5 # argument is -perl then the second is taken as the Perl command to use, and
    6 # both are then removed. If the next argument is "-w", Perl is called with
    7 # "-w", which turns on its warning mode.
    8 #
    9 # The Perl code has to have "use utf8" and "require Encode" at the start when
   10 # running UTF-8 tests, but *not* for non-utf8 tests. (The "require" would
   11 # actually be OK for non-utf8-tests, but is not always installed, so this way
   12 # the script will always run for these tests.)
   13 #
   14 # The desired effect is achieved by making this a shell script that passes the
   15 # Perl script to Perl through a pipe. If the next argument is "-utf8", a
   16 # suitable prefix is set up.
   17 #
   18 # The remaining arguments, if any, are passed to Perl. They are an input file
   19 # and an output file. If there is one argument, the output is written to
   20 # STDOUT. If Perl receives no arguments, it opens /dev/tty as input, and writes
   21 # output to STDOUT. (I haven't found a way of getting it to use STDIN, because
   22 # of the contorted piping input.)
   23 
   24 perl=perl
   25 perlarg=''
   26 prefix=''
   27 
   28 if [ $# -gt 1 -a "$1" = "-perl" ] ; then
   29   shift
   30   perl=$1
   31   shift
   32 fi
   33 
   34 if [ $# -gt 0 -a "$1" = "-w" ] ; then
   35   perlarg="-w"
   36   shift
   37 fi
   38 
   39 if [ $# -gt 0 -a "$1" = "-utf8" ] ; then
   40   prefix="use utf8; require Encode;"
   41   shift
   42 fi
   43 
   44 
   45 # The Perl script that follows has a similar specification to pcre2test, and so
   46 # can be given identical input, except that input patterns can be followed only
   47 # by Perl's lower case modifiers and certain other pcre2test modifiers that are
   48 # either handled or ignored:
   49 #
   50 #   aftertext          interpreted as "print $' afterwards"
   51 #   afteralltext       ignored
   52 #   dupnames           ignored (Perl always allows)
   53 #   jitstack           ignored
   54 #   mark               show mark information
   55 #   no_auto_possess    ignored
   56 #   no_start_optimize  insert (??{""}) at pattern start (disables optimizing)
   57 #  -no_start_optimize  ignored
   58 #   subject_literal    does not process subjects for escapes
   59 #   ucp                sets Perl's /u modifier
   60 #   utf                invoke UTF-8 functionality
   61 #
   62 # Comment lines are ignored. The #pattern command can be used to set modifiers
   63 # that will be added to each subsequent pattern, after any modifiers it may
   64 # already have. NOTE: this is different to pcre2test where #pattern sets
   65 # defaults which can be overridden on individual patterns. The #subject command
   66 # may be used to set or unset a default "mark" modifier for data lines. This is
   67 # the only use of #subject that is supported. The #perltest, #forbid_utf, and
   68 # #newline_default commands, which are needed in the relevant pcre2test files,
   69 # are ignored. Any other #-command is ignored, with a warning message.
   70 #
   71 # The pattern lines should use only / as the delimiter. The other characters
   72 # that pcre2test supports cause problems with this script.
   73 #
   74 # The data lines must not have any pcre2test modifiers. Unless
   75 # "subject_literal" is on the pattern, data lines are processed as
   76 # Perl double-quoted strings, so if they contain " $ or @ characters, these
   77 # have to be escaped. For this reason, all such characters in the
   78 # Perl-compatible testinput1 and testinput4 files are escaped so that they can
   79 # be used for perltest as well as for pcre2test. The output from this script
   80 # should be same as from pcre2test, apart from the initial identifying banner.
   81 #
   82 # The other testinput files are not suitable for feeding to perltest.sh,
   83 # because they make use of the special modifiers that pcre2test uses for
   84 # testing features of PCRE2. Some of these files also contain malformed regular
   85 # expressions, in order to check that PCRE2 diagnoses them correctly.
   86 
   87 (echo "$prefix" ; cat <<'PERLEND'
   88 
   89 # The alpha assertions currently give warnings even when -w is not specified.
   90 
   91 no warnings "experimental::alpha_assertions";
   92 no warnings "experimental::script_run";
   93 
   94 # Function for turning a string into a string of printing chars.
   95 
   96 sub pchars {
   97 my($t) = "";
   98 if ($utf8)
   99   {
  100   @p = unpack('U*', $_[0]);
  101   foreach $c (@p)
  102     {
  103     if ($c >= 32 && $c < 127) { $t .= chr $c; }
  104       else { $t .= sprintf("\\x{%02x}", $c);
  105       }
  106     }
  107   }
  108 else
  109   {
  110   foreach $c (split(//, $_[0]))
  111     {
  112     if (ord $c >= 32 && ord $c < 127) { $t .= $c; }
  113       else { $t .= sprintf("\\x%02x", ord $c); }
  114     }
  115   }
  116 $t;
  117 }
  118 
  119 
  120 # Read lines from a named file or stdin and write to a named file or stdout;
  121 # lines consist of a regular expression, in delimiters and optionally followed
  122 # by options, followed by a set of test data, terminated by an empty line.
  123 
  124 # Sort out the input and output files
  125 
  126 if (@ARGV > 0)
  127   {
  128   open(INFILE, "<$ARGV[0]") || die "Failed to open $ARGV[0]\n";
  129   $infile = "INFILE";
  130   $interact = 0;
  131   }
  132 else
  133   {
  134   open(INFILE, "</dev/tty") || die "Failed to open /dev/tty\n";
  135   $infile = "INFILE";
  136   $interact = 1;
  137   }
  138 
  139 if (@ARGV > 1)
  140   {
  141   open(OUTFILE, ">$ARGV[1]") || die "Failed to open $ARGV[1]\n";
  142   $outfile = "OUTFILE";
  143   }
  144 else { $outfile = "STDOUT"; }
  145 
  146 printf($outfile "Perl $^V\n\n");
  147 
  148 $extra_modifiers = "";
  149 $default_show_mark = 0;
  150 
  151 # Main loop
  152 
  153 NEXT_RE:
  154 for (;;)
  155   {
  156   printf "  re> " if $interact;
  157   last if ! ($_ = <$infile>);
  158   printf $outfile "$_" if ! $interact;
  159   next if ($_ =~ /^\s*$/ || $_ =~ /^#[\s!]/);
  160 
  161   # A few of pcre2test's #-commands are supported, or just ignored. Any others
  162   # cause an error.
  163 
  164   if ($_ =~ /^#pattern(.*)/)
  165     {
  166     $extra_modifiers = $1;
  167     chomp($extra_modifiers);
  168     $extra_modifiers =~ s/\s+$//;
  169     next;
  170     }
  171   elsif ($_ =~ /^#subject(.*)/)
  172     {
  173     $mod = $1;
  174     chomp($mod);
  175     $mod =~ s/\s+$//;
  176     if ($mod =~ s/(-?)mark,?//)
  177       {
  178       $minus = $1;
  179       $default_show_mark = ($minus =~ /^$/);
  180       }
  181     if ($mod !~ /^\s*$/)
  182       {
  183       printf $outfile "** Warning: \"$mod\" in #subject ignored\n";
  184       }
  185     next;
  186     }
  187   elsif ($_ =~ /^#/)
  188     {
  189     if ($_ !~ /^#newline_default|^#perltest|^#forbid_utf/)
  190       {
  191       printf $outfile "** Warning: #-command ignored: %s", $_;
  192       }
  193     next;
  194     }
  195 
  196   $pattern = $_;
  197 
  198   while ($pattern !~ /^\s*(.).*\1/s)
  199     {
  200     printf "    > " if $interact;
  201     last if ! ($_ = <$infile>);
  202     printf $outfile "$_" if ! $interact;
  203     $pattern .= $_;
  204     }
  205 
  206   chomp($pattern);
  207   $pattern =~ s/\s+$//;
  208 
  209   # Split the pattern from the modifiers and adjust them as necessary.
  210 
  211   $pattern =~ /^\s*((.).*\2)(.*)$/s;
  212   $pat = $1;
  213   $del = $2;
  214   $mod = "$3,$extra_modifiers";
  215   $mod =~ s/^,\s*//;
  216 
  217   # The private "aftertext" modifier means "print $' afterwards".
  218 
  219   $showrest = ($mod =~ s/aftertext,?//);
  220 
  221   # The "subject_literal" modifer disables escapes in subjects.
  222 
  223   $subject_literal = ($mod =~ s/subject_literal,?//);
  224 
  225   # "allaftertext" is used by pcre2test to print remainders after captures
  226 
  227   $mod =~ s/allaftertext,?//;
  228 
  229   # Detect utf
  230 
  231   $utf8 = $mod =~ s/utf,?//;
  232 
  233   # Remove "dupnames".
  234 
  235   $mod =~ s/dupnames,?//;
  236 
  237   # Remove "jitstack".
  238 
  239   $mod =~ s/jitstack=\d+,?//;
  240 
  241   # The "mark" modifier requests checking of MARK data */
  242 
  243   $show_mark = $default_show_mark | ($mod =~ s/mark,?//);
  244 
  245   # "ucp" asks pcre2test to set PCRE2_UCP; change this to /u for Perl
  246 
  247   $mod =~ s/ucp,?/u/;
  248 
  249   # Remove "no_auto_possess".
  250 
  251   $mod =~ s/no_auto_possess,?//;
  252 
  253   # Use no_start_optimize (disable PCRE2 start-up optimization) to disable Perl
  254   # optimization by inserting (??{""}) at the start of the pattern. We may
  255   # also encounter -no_start_optimize from a #pattern setting.
  256 
  257   $mod =~ s/-no_start_optimize,?//;
  258   if ($mod =~ s/no_start_optimize,?//) { $pat =~ s/$del/$del(??{""})/; }
  259 
  260   # Add back retained modifiers and check that the pattern is valid.
  261 
  262   $mod =~ s/,//g;
  263   $pattern = "$pat$mod";
  264   eval "\$_ =~ ${pattern}";
  265   if ($@)
  266     {
  267     printf $outfile "Error: $@";
  268     if (! $interact)
  269       {
  270       for (;;)
  271         {
  272         last if ! ($_ = <$infile>);
  273         last if $_ =~ /^\s*$/;
  274         }
  275       }
  276     next NEXT_RE;
  277     }
  278 
  279   # If the /g modifier is present, we want to put a loop round the matching;
  280   # otherwise just a single "if".
  281 
  282   $cmd = ($pattern =~ /g[a-z]*$/)? "while" : "if";
  283 
  284   # If the pattern is actually the null string, Perl uses the most recently
  285   # executed (and successfully compiled) regex is used instead. This is a
  286   # nasty trap for the unwary! The PCRE2 test suite does contain null strings
  287   # in places - if they are allowed through here all sorts of weird and
  288   # unexpected effects happen. To avoid this, we replace such patterns with
  289   # a non-null pattern that has the same effect.
  290 
  291   $pattern = "/(?#)/$2" if ($pattern =~ /^(.)\1(.*)$/);
  292 
  293   # Read data lines and test them
  294 
  295   for (;;)
  296     {
  297     printf "data> " if $interact;
  298     last NEXT_RE if ! ($_ = <$infile>);
  299     chomp;
  300     printf $outfile "%s", "$_\n" if ! $interact;
  301 
  302     s/\s+$//;  # Remove trailing space
  303     s/^\s+//;  # Remove leading space
  304 
  305     last if ($_ eq "");
  306     next if $_ =~ /^\\=(?:\s|$)/;   # Comment line
  307 
  308     if ($subject_literal)
  309       {
  310       $x = $_;
  311       }
  312     else
  313       {
  314       $x = eval "\"$_\"";   # To get escapes processed
  315       }
  316 
  317     # Empty array for holding results, ensure $REGERROR and $REGMARK are
  318     # unset, then do the matching.
  319 
  320     @subs = ();
  321 
  322     $pushes = "push \@subs,\$&;" .
  323          "push \@subs,\$1;" .
  324          "push \@subs,\$2;" .
  325          "push \@subs,\$3;" .
  326          "push \@subs,\$4;" .
  327          "push \@subs,\$5;" .
  328          "push \@subs,\$6;" .
  329          "push \@subs,\$7;" .
  330          "push \@subs,\$8;" .
  331          "push \@subs,\$9;" .
  332          "push \@subs,\$10;" .
  333          "push \@subs,\$11;" .
  334          "push \@subs,\$12;" .
  335          "push \@subs,\$13;" .
  336          "push \@subs,\$14;" .
  337          "push \@subs,\$15;" .
  338          "push \@subs,\$16;" .
  339          "push \@subs,\$'; }";
  340 
  341     undef $REGERROR;
  342     undef $REGMARK;
  343 
  344     eval "${cmd} (\$x =~ ${pattern}) {" . $pushes;
  345 
  346     if ($@)
  347       {
  348       printf $outfile "Error: $@\n";
  349       next NEXT_RE;
  350       }
  351     elsif (scalar(@subs) == 0)
  352       {
  353       printf $outfile "No match";
  354       if ($show_mark && defined $REGERROR && $REGERROR != 1)
  355         { printf $outfile (", mark = %s", &pchars($REGERROR)); }
  356       printf $outfile "\n";
  357       }
  358     else
  359       {
  360       while (scalar(@subs) != 0)
  361         {
  362         printf $outfile (" 0: %s\n", &pchars($subs[0]));
  363         printf $outfile (" 0+ %s\n", &pchars($subs[17])) if $showrest;
  364         $last_printed = 0;
  365         for ($i = 1; $i <= 16; $i++)
  366           {
  367           if (defined $subs[$i])
  368             {
  369             while ($last_printed++ < $i-1)
  370               { printf $outfile ("%2d: <unset>\n", $last_printed); }
  371             printf $outfile ("%2d: %s\n", $i, &pchars($subs[$i]));
  372             $last_printed = $i;
  373             }
  374           }
  375         splice(@subs, 0, 18);
  376         }
  377 
  378       # It seems that $REGMARK is not marked as UTF-8 even when use utf8 is
  379       # set and the input pattern was a UTF-8 string. We can, however, force
  380       # it to be so marked.
  381 
  382       if ($show_mark && defined $REGMARK && $REGMARK != 1)
  383         {
  384         $xx = $REGMARK;
  385         $xx = Encode::decode_utf8($xx) if $utf8;
  386         printf $outfile ("MK: %s\n", &pchars($xx));
  387         }
  388       }
  389     }
  390   }
  391 
  392 # By closing OUTFILE explicitly, we avoid a Perl warning in -w mode
  393 # "main::OUTFILE" used only once".
  394 
  395 close(OUTFILE) if $outfile eq "OUTFILE";
  396 
  397 PERLEND
  398 ) | $perl $perlarg - $@
  399 
  400 # End