Inital Import.
[jquery.git] / browse / ParseMaster.pm
1 #ParseMaster (July 25 2005)\r
2 #  Based on "ParseMaster.js" by Dean Edwards <http://dean.edwards.name/>\r
3 #  Ported to Perl by Rob Seiler, ELR Software Pty Ltd <http://www.elr.com.au>\r
4 #  Copyright 2005. License <http://creativecommons.org/licenses/LGPL/2.1/>\r
5 \r
6 package ParseMaster;\r
7 use strict;\r
8 use Data::Dumper;\r
9 \r
10 # Package wide variable declarations\r
11 use vars qw/$VERSION\r
12             @_X_escaped @_X_patterns\r
13            /;\r
14 \r
15 $VERSION    = '017';\r
16 \r
17 # constants\r
18 my $X_EXPRESSION  = 0;\r
19 my $X_REPLACEMENT = 1;\r
20 my $X_LENGTH      = 2;\r
21 \r
22 # re's used to determine nesting levels\r
23 my $X_GROUPS      = qr/\(/o;                # NB: Requires g modifier!\r
24 my $X_SUB_REPLACE = qr/\$\d/o;\r
25 my $X_INDEXED     = qr/^\$\d+$/o;\r
26 my $XX_ESCAPE     = qr/\\./o;               # NB: Requires g modifier!\r
27 my $XX_DELETED    = qr/\001[^\001]*\001/o;  # NB: Requires g modifier!\r
28 my $DIGIT         = qr/[^\D]/o;             # Yep - this is a digit - contains no non-digits\r
29 \r
30 # Constructor\r
31 sub new {\r
32   my $class = shift;\r
33   my $self  = {};\r
34   @_X_escaped  = ();  # Re-initialize global for each instance\r
35   @_X_patterns = ();  # Re-initialize global for each instance\r
36   # Instance variables - access by similarly named set/get functions\r
37   $self->{_ignoreCase_} = 0;\r
38   $self->{_escapeChar_} = '';\r
39   bless ($self, $class);\r
40   return $self;\r
41 }\r
42 \r
43 sub ignoreCase {\r
44   my ($self, $value) = @_;\r
45   if (defined($value)) {\r
46     $self->{_ignoreCase_} = $value;\r
47   }\r
48   return $self->{_ignoreCase_};\r
49 }\r
50 \r
51 sub escapeChar{\r
52   my ($self, $value) = @_;\r
53   if (defined($value)) {\r
54     $self->{_escapeChar_} = $value;\r
55   }\r
56   return $self->{_escapeChar_};\r
57 }\r
58 \r
59 #######################\r
60 # Public Parsemaster functions\r
61 \r
62 my $X_DELETE = sub(@$) {\r
63   my $X_offset = pop;\r
64   my @X_match = @_;\r
65   return (chr(001) . $X_match[$X_offset] . chr(001));\r
66 }; # NB semicolon required for closure!\r
67 \r
68 # create and add a new pattern to the patterns collection\r
69 sub add {\r
70   my ($self, $expression, $X_replacement) = @_;\r
71   if (!$X_replacement) {$X_replacement = $X_DELETE};\r
72 \r
73   # count the number of sub-expressions\r
74   my $temp = &_X_internalEscape($expression);\r
75   my $length  = 1; # Always at least one because each pattern is itself a sub-expression\r
76      $length += $temp =~ s/$X_GROUPS//g; # One way to count the left capturing parentheses in the regexp string\r
77 \r
78   # does the pattern deal with sub-expressions?\r
79   if ((ref($X_replacement) ne "CODE") && ($X_replacement =~ m/$X_SUB_REPLACE/)) {\r
80     if ($X_replacement =~ m/$X_INDEXED/) { # a simple lookup? (eg "$2")\r
81       # store the index (used for fast retrieval of matched strings)\r
82       $X_replacement = substr($X_replacement,1) - 1;\r
83     }\r
84     else { # a complicated lookup (eg "Hello $2 $1")\r
85       my $i = $length;\r
86       while ($i) { # Had difficulty getting Perl to do Dean's splitting and joining of strings containing $'s\r
87         my $str = '$a[$o+' . ($i-1) . ']'; # eg $a[$o+1]\r
88         $X_replacement =~ s/\$$i/$str/;      # eg $2 $3 -> $a[$o+1] $a[$o+2]\r
89         $i--;\r
90       }\r
91       # build a function to do the lookup - returns interpolated string of array lookups\r
92       $X_replacement = eval('sub {my $o=pop; my @a=@_; return "' . $X_replacement . '"};');\r
93     }\r
94   }\r
95   else {}\r
96   # pass the modified arguments\r
97   &_X_add($expression || q/^$/, $X_replacement, $length);\r
98 }\r
99 \r
100 # execute the global replacement\r
101 sub exec {\r
102 #print Dumper(@_X_patterns);\r
103   my ($self, $X_string) = @_;\r
104   my $escChar    = $self->escapeChar();\r
105   my $ignoreCase = $self->ignoreCase();\r
106   my ($regexp,$captures) = &_getPatterns();  # Concatenated and parenthesized regexp eg '(regex1)|(regex2)|(regex3)' etc\r
107   $X_string = &_X_escape($X_string, $escChar);\r
108   if ($ignoreCase) {$X_string =~ s/$regexp/{&_X_replacement(&_matchVars($captures,\$X_string))}/gie} # Pass $X_String as a\r
109     else           {$X_string =~ s/$regexp/{&_X_replacement(&_matchVars($captures,\$X_string))}/ge}  # reference for speed\r
110 \r
111   $X_string = &_X_unescape($X_string, $escChar);\r
112   $X_string =~ s/$XX_DELETED//g;\r
113   return $X_string;\r
114 }\r
115 \r
116 sub _X_add {\r
117   push (@_X_patterns, [@_]); # Save each argument set as is into an array of arrays\r
118 }\r
119 \r
120 # this is the global replace function (it's quite complicated)\r
121 sub _X_replacement {\r
122   my (@arguments) = @_;\r
123 #print Dumper (@arguments);\r
124   if ($arguments[0] le '') {return ''}\r
125   # Dereference last index (source String) here - faster than in _matchVars (maybe not needed at all?)\r
126   $arguments[$#arguments] = ${$arguments[$#arguments]};\r
127   my $i = 1;\r
128   # loop through the patterns\r
129   for (my $j=0; $j<scalar(@_X_patterns); $j++) { # Loop through global all @_X_patterns\r
130     my @X_pattern = @{$_X_patterns[$j]};\r
131     # do we have a result? NB: "if ($arguments[$i])" as in Dean's Javascript is false for the value 0!!!\r
132     if ((defined $arguments[$i]) && ($arguments[$i] gt '')) {\r
133       my $X_replacement = $X_pattern[$X_REPLACEMENT];\r
134       # switch on type of $replacement\r
135       if (ref($X_replacement) eq "CODE") {     # function\r
136         return &$X_replacement(@arguments,$i);\r
137       }\r
138       elsif ($X_replacement =~ m/$DIGIT/) {    # number (contains no non-digits)\r
139         return $arguments[$X_replacement + $i];\r
140       }\r
141       else { # default\r
142         return $X_replacement;                 # default\r
143       }\r
144     } # skip over references to sub-expressions\r
145     else {$i += $X_pattern[$X_LENGTH]}\r
146   }\r
147 }\r
148 \r
149 #######################\r
150 # Private functions\r
151 #######################\r
152 \r
153 # encode escaped characters\r
154 sub _X_escape {\r
155   my ($X_string, $X_escapeChar) = @_;\r
156   if ($X_escapeChar) {\r
157     my $re = '\\'.$X_escapeChar.'(.)';\r
158     $X_string =~ s/$re/{push(@_X_escaped,$1); $X_escapeChar}/ge;\r
159   }\r
160   return $X_string;\r
161 }\r
162 \r
163 # decode escaped characters\r
164 sub _X_unescape {\r
165   my ($X_string, $X_escapeChar) = @_;\r
166   if ($X_escapeChar) { # We'll only do this if there is an $X_escapeChar!\r
167     my $re = '\\'.$X_escapeChar;\r
168     $X_string =~ s/$re/{$X_escapeChar . (shift(@_X_escaped))}/ge; # Don't use Dean Edwards as below 'or' here - because zero will return ''!\r
169   # $X_string =~ s/$re/{$X_escapeChar . (shift(@_X_escaped) || '')}/ge;\r
170   }\r
171   return $X_string;\r
172 }\r
173 \r
174 sub _X_internalEscape {\r
175   my ($string) = shift;\r
176   $string =~ s/$XX_ESCAPE//g;\r
177   return $string;\r
178 }\r
179 \r
180 # Builds an array of match variables to (approximately) emulate that available in Javascript String.replace()\r
181 sub _matchVars {\r
182   my ($m,$sref) = @_;\r
183   my @args = (1..$m);                # establish the number potential memory variables\r
184   my @mv = map {eval("\$$_")} @args; # matchvarv[1..m] = the memory variables $1 .. $m\r
185   unshift (@mv, $&);                 # matchvar[0]     = the substring that matched\r
186   push    (@mv, length($`));         # matchvar[m+1]   =  offset within the source string where the match occurred (= length of prematch string)\r
187   push    (@mv, $sref);              # matchvar[m+2]   = reference to full source string (dereference in caller if/when needed)\r
188 #print Dumper (@mv);\r
189   return @mv;\r
190 }\r
191 \r
192 sub _getPatterns {\r
193   my @Patterns = ();\r
194   my $lcp = 0;\r
195   for (my $i=0; $i<scalar(@_X_patterns); $i++) {       # Loop through global all @_patterns\r
196     push (@Patterns, $_X_patterns[$i][$X_EXPRESSION]); # accumulate the expressions\r
197     $lcp += $_X_patterns[$i][$X_LENGTH];               # sum the left capturing parenthesis counts\r
198   }\r
199   my $str = "(" . join(')|(',@Patterns). ")";          # enclose each pattern in () separated by "|"\r
200   return ($str, $lcp);\r
201 }\r
202 \r
203 ##################\r
204 # END            #\r
205 ##################\r
206 1; # ParseMaster #\r
207 ##################\r