+++ /dev/null
-#Pack (July 2005)\r
-# Based on "Pack.js" by Dean Edwards <http://dean.edwards.name/>\r
-# Ported to Perl by Rob Seiler, ELR Software Pty Ltd <http://www.elr.com.au>\r
-# Copyright 2005. License <http://creativecommons.org/licenses/LGPL/2.1/>\r
-\r
-package Pack;\r
-use strict;\r
-use Data::Dumper;\r
-\r
-use ParseMaster;\r
-\r
-# Package wide variable declarations\r
-use vars qw/$VERSION $PM_VERSION\r
- $_X_encodePrivate $_JSunpack $_JSdecode %baseLookup\r
- $_X_encode10 $_X_encode36 $_X_encode62 $_X_encode95\r
- $_JSencode10 $_JSencode36 $_JSencode62 $_JSencode95\r
- @_X_parsers\r
- $_X_script $_X_encoding $_X_fastDecode $_X_specialChars\r
- /;\r
-$VERSION = '024';\r
-$PM_VERSION = $ParseMaster::VERSION;\r
-\r
-# Package wide constants\r
-my $X_IGNORE = q{$1};\r
-my $X_ENCODE = q/\x24encode\(\x24count\)/; # NB: requires g modifier\r
-my $PERL = 'perl'; # Flag to indicate whether we need to use one of our "internal" Perl encoding functions\r
-my $JSCRIPT = 'jscript'; # or embed a pre-build JScript encoding function\r
-########################################\r
-\r
-##################\r
-sub pack($$$$) { # require 4 arguments\r
-##################\r
-#print Dumper(@_);\r
- ($_X_script, $_X_encoding, $_X_fastDecode, $_X_specialChars) = @_;\r
- # validate parameters (sort of!)\r
- $_X_script .= "\n";\r
- $_X_encoding = ($_X_encoding > 95) ? 95 : $_X_encoding;\r
-\r
- @_X_parsers = (); # Reset parsers\r
-\r
-####################\r
- sub _X_pack($) { # require 1 argument\r
-####################\r
- # apply all parsing routines\r
- my $X_script = shift;\r
- for (my $i = 0; $i<scalar(@_X_parsers); $i++) {\r
- my $X_parse = $_X_parsers[$i];\r
- $X_script = &$X_parse($X_script);\r
- }\r
- return $X_script;\r
- };\r
-\r
-######################\r
- sub _X_addParser { #\r
-######################\r
- # keep a list of parsing functions, they'll be executed all at once\r
- my $X_parser = shift;\r
- push (@_X_parsers,$X_parser);\r
- }\r
-\r
-#############################\r
- sub _X_basicCompression { #\r
-#############################\r
- # zero encoding - just removal of white space and comments\r
- my $X_script = shift;\r
- my $parser = ParseMaster->new();\r
- # make safe\r
- $parser->escapeChar("\\");\r
- # protect strings\r
- $parser->add(q/'[^'\n\r]*'/, $X_IGNORE);\r
- $parser->add(q/"[^"\n\r]*"/, $X_IGNORE);\r
- # remove comments\r
- $parser->add(q/\/\/[^\n\r]*[\n\r]/);\r
- $parser->add(q/\/\*[^*]*\*+([^\/][^*]*\*+)*\//);\r
- # protect regular expressions\r
- $parser->add(q/\s+(\/[^\/\n\r\*][^\/\n\r]*\/g?i?)/, q{$2}); # IGNORE\r
- $parser->add(q/[^\w\x24\/'"*)\?:]\/[^\/\n\r\*][^\/\n\r]*\/g?i?/, $X_IGNORE);\r
- # remove: ;;; doSomething();\r
- $parser->add(q/;;[^\n\r]+[\n\r]/) if ($_X_specialChars);\r
- # remove redundant semi-colons\r
- $parser->add(q/;+\s*([};])/, q{$2});\r
- # remove white-space\r
- $parser->add(q/(\b|\x24)\s+(\b|\x24)/, q{$2 $3});\r
- $parser->add(q/([+\-])\s+([+\-])/, q{$2 $3});\r
- $parser->add(q/\s+/, '');\r
- # done\r
- return $parser->exec($X_script);\r
- }\r
-\r
-###############################\r
- sub _X_encodeSpecialChars { #\r
-###############################\r
- my $X_script = shift;\r
- my $parser = ParseMaster->new();\r
- # replace: $name -> n, $$name -> $$na\r
- $parser->add(q/((\x24+)([a-zA-Z\x24_]+))(\d*)/,\r
- sub {\r
- my $X_offset = pop;\r
- my @X_match = @_;\r
- my $X_length = length($X_match[$X_offset+2]);\r
- my $lengthnext = length($X_match[$X_offset+3]);\r
- my $X_start = $X_length - ((($X_length - $lengthnext) > 0) ? ($X_length - $lengthnext) : 0);\r
- my $str = $X_match[$X_offset+1];\r
- $str = substr($str,$X_start,$X_length) . $X_match[$X_offset+4];\r
- return "$str";\r
- });\r
- # replace: _name -> _0, double-underscore (__name) is ignored\r
- my $X_regexp = q/\b_[A-Za-z\d]\w*/;\r
- # build the word list\r
- my %X_keywords = &_X_analyze($X_script, $X_regexp, $_X_encodePrivate);\r
-#print Dumper(%X_keywords);\r
- # quick ref\r
- my $X_encoded = \$X_keywords{X_encoded}; # eg _private1 => '_0',_private2 => '_1';\r
-#print Dumper($X_encoded);\r
- $parser->add($X_regexp, sub {my $X_offset = pop; my @X_match = @_; return ${$X_encoded}->{$X_match[$X_offset]};});\r
-\r
- return $parser->exec($X_script);\r
- };\r
-\r
-###########################\r
- sub _X_encodeKeywords { #\r
-###########################\r
- my $X_script = shift;\r
- # escape high-ascii values already in the script (i.e. in strings)\r
- if ($_X_encoding > 62) {$X_script = &_X_escape95($X_script)};\r
- # create the parser\r
- my $parser = ParseMaster->new();\r
- my $X_encode = &_X_getEncoder($_X_encoding,$PERL);\r
- # for high-ascii, don't encode single character low-ascii\r
- my $X_regexp = ($_X_encoding > 62) ? q/\w\w+/ : q/\w+/;\r
- # build the word list\r
- my %X_keywords = &_X_analyze($X_script, $X_regexp, $X_encode);\r
-#print Dumper(%X_keywords);\r
- my $X_encoded = \$X_keywords{X_encoded}; # eg alert => 2, function => 10 etc\r
- # encode\r
- $parser->add($X_regexp, sub {my $X_offset = pop; my @X_match = @_; return ${$X_encoded}->{$X_match[$X_offset]};});\r
- # if encoded, wrap the script in a decoding function\r
-\r
- return $X_script && _X_bootStrap(\$parser->exec($X_script), \%X_keywords);\r
- }\r
-\r
-####################\r
- sub _X_analyze { #\r
-####################\r
-#print Dumper(@_);\r
- my ($X_script, $X_regexp, $X_encode) = @_;\r
- # analyse\r
- # retreive all words in the script\r
- my @X_all = $X_script =~ m/$X_regexp/g; # Save all captures in a list context\r
- my %XX_sorted = (); # list of words sorted by frequency\r
- my %XX_encoded = (); # dictionary of word->encoding\r
- my %XX_protected = (); # instances of "protected" words\r
- if (@X_all) {\r
- my @X_unsorted = (); # same list, not sorted\r
- my %X_protected = (); # "protected" words (dictionary of word->"word")\r
- my %X_values = (); # dictionary of charCode->encoding (eg. 256->ff)\r
- my %X_count = (); # word->count\r
- my $i = scalar(@X_all); my $j = 0; my $X_word = '';\r
- # count the occurrences - used for sorting later\r
- do {\r
- $X_word = '$' . $X_all[--$i];\r
- if (!exists($X_count{$X_word})) {\r
- $X_count{$X_word} = [0,$i]; # Store both the usage count and original array position (ie a secondary sort key)\r
- $X_unsorted[$j] = $X_word;\r
- # make a dictionary of all of the protected words in this script\r
- # these are words that might be mistaken for encoding\r
- $X_values{$j} = &$X_encode($j);\r
- my $v = '$'.$X_values{$j};\r
- $X_protected{$v} = $j++;\r
- }\r
- # increment the word counter\r
- $X_count{$X_word}[0]++;\r
- } while ($i);\r
-#print Dumper (%X_values);\r
-#print Dumper (@X_unsorted);\r
-#print Dumper (%X_protected);\r
- # prepare to sort the word list, first we must protect\r
- # words that are also used as codes. we assign them a code\r
- # equivalent to the word itself.\r
- # e.g. if "do" falls within our encoding range\r
- # then we store keywords["do"] = "do";\r
- # this avoids problems when decoding\r
- $i = scalar(@X_unsorted);\r
- do {\r
- $X_word = $X_unsorted[--$i];\r
- if (exists($X_protected{$X_word})) {\r
- $XX_sorted{$X_protected{$X_word}} = substr($X_word,1);\r
- $XX_protected{$X_protected{$X_word}} = 1; # true\r
- $X_count{$X_word}[0] = 0;\r
- }\r
- } while ($i);\r
-#print Dumper (%XX_protected);\r
-#print Dumper (%XX_sorted);\r
-#print Dumper (%X_count);\r
- # sort the words by frequency\r
- # Sort with count a primary key and original array order as secondary key - which is apparently the default in javascript!\r
- @X_unsorted = sort ({($X_count{$b}[0] - $X_count{$a}[0]) or ($X_count{$b}[1] <=> $X_count{$a}[1])} @X_unsorted);\r
-#print Dumper (@X_unsorted) . "\n";\r
-\r
- $j = 0;\r
- # because there are "protected" words in the list\r
- # we must add the sorted words around them\r
- do {\r
- if (!exists($XX_sorted{$i})) {$XX_sorted{$i} = substr($X_unsorted[$j++],1)}\r
- $XX_encoded{$XX_sorted{$i}} = $X_values{$i};\r
- } while (++$i < scalar(@X_unsorted));\r
- }\r
-#print Dumper(X_sorted => \%XX_sorted, X_encoded => \%XX_encoded, X_protected => \%XX_protected);\r
- return (X_sorted => \%XX_sorted, X_encoded => \%XX_encoded, X_protected => \%XX_protected);\r
- }\r
-\r
-######################\r
- sub _X_bootStrap { #\r
-######################\r
- # build the boot function used for loading and decoding\r
- my ($X_packed, $X_keywords) = @_; # Reference arguments!\r
-#print Dumper ($X_keywords) . "\n";\r
-\r
- # $packed: the packed script - dereference and escape\r
- $X_packed = "'" . &_X_escape($$X_packed) ."'";\r
-\r
- my %sorted = %{$$X_keywords{X_sorted}}; # Dereference to local variables\r
- my %protected = %{$$X_keywords{X_protected}}; # for simplicity\r
-\r
- my @sorted = ();\r
- foreach my $key (keys %sorted) {$sorted[$key] = $sorted{$key}}; # Convert hash to a standard list\r
-\r
- # ascii: base for encoding\r
- my $X_ascii = ((scalar(@sorted) > $_X_encoding) ? $_X_encoding : scalar(@sorted)) || 1;\r
-\r
- # count: number of (unique {RS}) words contained in the script\r
- my $X_count = scalar(@sorted); # Use $X_count for assigning $X_ascii\r
-\r
- # keywords: list of words contained in the script\r
- foreach my $i (keys %protected) {$sorted[$i] = ''}; # Blank out protected words\r
-#print Dumper(@sorted) . "\n";\r
-\r
- # convert from a string to an array - prepare keywords as a JScript string->array {RS}\r
- $X_keywords = "'" . join('|',@sorted) . "'.split('|')";\r
-\r
- # encode: encoding function (used for decoding the script)\r
- my $X_encode = $_X_encoding > 62 ? $_JSencode95 : &_X_getEncoder($X_ascii,$JSCRIPT); # This is a JScript function (as a string)\r
- $X_encode =~ s/_encoding/\x24ascii/g; $X_encode =~ s/arguments\.callee/\x24encode/g;\r
- my $X_inline = '$count' . ($X_ascii > 10 ? '.toString($ascii)' : '');\r
-\r
- # decode: code snippet to speed up decoding\r
- my $X_decode = '';\r
- if ($_X_fastDecode) {\r
- # create the decoder\r
- $X_decode = &_X_getFunctionBody($_JSdecode); # ie from the Javascript literal function\r
- if ($_X_encoding > 62) {$X_decode =~ s/\\\\w/[\\xa1-\\xff]/g}\r
- # perform the encoding inline for lower ascii values\r
- elsif ($X_ascii < 36) {$X_decode =~ s/$X_ENCODE/$X_inline/g}\r
- # special case: when $X_count==0 there ar no keywords. i want to keep\r
- # the basic shape of the unpacking funcion so i'll frig the code...\r
- if (!$X_count) {$X_decode =~ s/(\x24count)\s*=\s*1/$1=0/}\r
- }\r
-\r
- # boot function\r
- my $X_unpack = $_JSunpack;\r
- if ($_X_fastDecode) {\r
- # insert the decoder\r
- $X_unpack =~ s/\{/\{$X_decode;/;\r
- }\r
- $X_unpack =~ s/"/'/g;\r
- if ($_X_encoding > 62) { # high-ascii\r
- # get rid of the word-boundaries for regexp matches\r
- $X_unpack =~ s/'\\\\b'\s*\+|\+\s*'\\\\b'//g; # Not checked! {RS}\r
- }\r
- if ($X_ascii > 36 || $_X_encoding > 62 || $_X_fastDecode) {\r
- # insert the encode function\r
- $X_unpack =~ s/\{/\{\$encode=$X_encode;/;\r
- } else {\r
- # perform the encoding inline\r
- $X_unpack =~ s/$X_ENCODE/$X_inline/;\r
- }\r
-\r
- # arguments {RS} Do this before using &pack because &pack changes the pack parameters (eg $fastDecode) in Perl!!\r
- my $X_params = "$X_packed,$X_ascii,$X_count,$X_keywords"; # Interpolate to comma separated string\r
- if ($_X_fastDecode) {\r
- # insert placeholders for the decoder\r
- $X_params .= ',0,{}';\r
- }\r
-\r
- # pack the boot function too\r
- $X_unpack = &pack($X_unpack,0,0,1);\r
-\r
- # the whole thing\r
- return "eval(" . $X_unpack . "(" . $X_params . "))\n";\r
- };\r
-\r
-#######################\r
- sub _X_getEncoder { #\r
-#######################\r
- # mmm.. ..which one do i need ?? ({RS} Perl or JScript ??)\r
- my ($X_ascii,$language) = @_;\r
- my $perl_encoder = ($X_ascii > 10) ? ($X_ascii > 36) ? ($X_ascii > 62) ? $_X_encode95 : $_X_encode62 : $_X_encode36 : $_X_encode10;\r
- my $jscript_encoder = ($X_ascii > 10) ? ($X_ascii > 36) ? ($X_ascii > 62) ? $_JSencode95 : $_JSencode62 : $_JSencode36 : $_JSencode10;\r
- return ($language eq $JSCRIPT) ? $jscript_encoder : $perl_encoder;\r
- };\r
-\r
-#############################\r
-# Perl versions of encoders #\r
-#############################\r
- # base10 zero encoding - characters: 0123456789\r
- $_X_encode10 = sub {return &_encodeBase(shift,10)};\r
- # base36 - characters: 0123456789abcdefghijklmnopqrstuvwxyz\r
- $_X_encode36 = sub {return &_encodeBase(shift,36)};\r
- # base62 - characters: 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\r
- $_X_encode62 = sub {return &_encodeBase(shift,62)};\r
- # high-ascii values - characters: ¡¢£¤¥¦§¨©ª«¬®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõö÷øùúûüýþ\r
- $_X_encode95 = sub {return &_encodeBase(shift,95)};\r
- # Lookup character sets for baseN encoding\r
- $baseLookup{10} = [(0..9)[0..9]]; # base 10\r
- $baseLookup{36} = [(0..9,'a'..'z')[0..35]]; # base 36\r
- $baseLookup{62} = [(0..9,'a'..'z','A'..'Z')[0..61]]; # base 62\r
- $baseLookup{95} = (); for (my $i=0; $i<95; $i++) {$baseLookup{95}[$i] = chr($i+161)}; # base95 (high ascii)\r
-#print Dumper(%baseLookup);\r
-#####################\r
- sub _encodeBase { #\r
-#####################\r
- # Generic base conversion function using defined lookup arrays (perl version only)\r
- my ($X_charCode, $base) = @_;\r
- my $X_encoded = '';\r
- # Do we know this encoding?\r
- if (exists ($baseLookup{$base})) {\r
- if ($X_charCode == 0) {$X_encoded = $baseLookup{$base}[0]}\r
- while($X_charCode > 0) {\r
- $X_encoded = $baseLookup{$base}[$X_charCode % $base] . $X_encoded;\r
- $X_charCode = int($X_charCode / $base);\r
- }\r
- }\r
- else {$X_encoded = "$X_charCode"} # default is to return unchanged (ie as for base 10) if no baselookup is available\r
- return $X_encoded;\r
- };\r
-\r
-#############################\r
- $_X_encodePrivate = sub { #\r
-#############################\r
- # special _chars\r
- my $X_charCode = shift;\r
- return '_' . $X_charCode;\r
- };\r
-\r
-############################\r
- sub _X_escape($script) { #\r
-############################\r
- # protect characters used by the parser\r
- my $X_script = shift;\r
- $X_script =~ s/([\\'])/\\$1/g;\r
- return $X_script;\r
- };\r
-\r
-#####################\r
- sub _X_escape95 { #\r
-#####################\r
- # protect high-ascii characters already in the script\r
- my $X_script = shift;\r
- $X_script =~ s/([\xa1-\xff])/sprintf("\\x%1x",ord($1))/eg;\r
- return $X_script;\r
- };\r
-\r
-############################\r
- sub _X_getFunctionBody { #\r
-############################\r
- # extract the body of a function (ie between opening/closing {}) - consistent with Dean Edwards approach\r
- my $X_function = shift;\r
- $X_function =~ m/^.*\{(.*)\}*$/sg; # Multiline, global (greedy)\r
- my $start = index($X_function,'{');\r
- my $end = rindex($X_function,'}');\r
- $X_function = substr($X_function,($start+1),($end-1-$start));\r
- return $X_function;\r
- };\r
-\r
-######################\r
- sub _X_globalize { #\r
-######################\r
- # set the global flag on a RegExp (you have to create a new one) !!! Unused in perl version\r
- # my $X_regexp = shift;\r
- };\r
-\r
- # build the parsing routine\r
- &_X_addParser(\&_X_basicCompression);\r
- &_X_addParser(\&_X_encodeSpecialChars) if ($_X_specialChars);\r
- &_X_addParser(\&_X_encodeKeywords) if ($_X_encoding);\r
-\r
- # go!\r
- return &_X_pack($_X_script);\r
-}\r
-\r
-########################\r
-# Javascript Literals #\r
-########################\r
-\r
-# JScript function "_unpack" - from DeanEdwards pack.js (NB: No ";" after final "}")\r
-($_JSunpack) = <<'END_JSCRIPT_UNPACK';\r
-/* unpacking function - this is the boot strap function */\r
-/* data extracted from this packing routine is passed to */\r
-/* this function when decoded in the target */\r
-function($packed, $ascii, $count, $keywords, $encode, $decode) {\r
- while ($count--)\r
- if ($keywords[$count])\r
- $packed = $packed.replace(new RegExp('\\b' + $encode($count) + '\\b', 'g'), $keywords[$count]);\r
- /* RS_Debug = $packed; */ /* {RS} !!!!!!!!! */\r
- return $packed;\r
-}\r
-END_JSCRIPT_UNPACK\r
-\r
-# JScript function "_decode" - from DeanEdwards pack.js\r
-($_JSdecode) = <<'END_JSCRIPT_DECODE';\r
- /* code-snippet inserted into the unpacker to speed up decoding */\r
- function() {\r
- /* does the browser support String.replace where the */\r
- /* replacement value is a function? */\r
- if (!''.replace(/^/, String)) {\r
- /* decode all the values we need */\r
- while ($count--) $decode[$encode($count)] = $keywords[$count] || $encode($count);\r
- /* global replacement function */\r
- $keywords = [function($encoded){return $decode[$encoded]}];\r
- /* generic match */\r
- $encode = function(){return'\\w+'};\r
- /* reset the loop counter - we are now doing a global replace */\r
- $count = 1;\r
- }\r
- };\r
-END_JSCRIPT_DECODE\r
-\r
-# JScript versions of encoders\r
-($_JSencode10) = <<'END_JSCRIPT_ENCODE10';\r
- /* zero encoding */\r
- /* characters: 0123456789 */\r
- function($charCode) {\r
- return $charCode;\r
- };\r
-END_JSCRIPT_ENCODE10\r
-\r
-($_JSencode36) = <<'END_JSCRIPT_ENCODE36';\r
- /* inherent base36 support */\r
- /* characters: 0123456789abcdefghijklmnopqrstuvwxyz */\r
- function($charCode) {\r
- return $charCode.toString(36);\r
- };\r
-END_JSCRIPT_ENCODE36\r
-\r
-($_JSencode62) = <<'END_JSCRIPT_ENCODE62';\r
- /* hitch a ride on base36 and add the upper case alpha characters */\r
- /* characters: 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ */\r
- function($charCode) {\r
- return ($charCode < _encoding ? '' : arguments.callee(parseInt($charCode / _encoding))) +\r
- (($charCode = $charCode % _encoding) > 35 ? String.fromCharCode($charCode + 29) : $charCode.toString(36));\r
- };\r
-END_JSCRIPT_ENCODE62\r
-\r
-($_JSencode95) = <<'END_JSCRIPT_ENCODE95';\r
- /* use high-ascii values */\r
- /* characters: ¡¢£¤¥¦§¨©ª«¬®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõö÷øùúûüýþ */\r
- function($charCode) {\r
- return ($charCode < _encoding ? '' : arguments.callee($charCode / _encoding)) +\r
- String.fromCharCode($charCode % _encoding + 161);\r
- };\r
-END_JSCRIPT_ENCODE95\r
-\r
-###########\r
-# END #\r
-###########\r
-1; # Pack #\r
-###########\r
+++ /dev/null
-#ParseMaster (July 25 2005)\r
-# Based on "ParseMaster.js" by Dean Edwards <http://dean.edwards.name/>\r
-# Ported to Perl by Rob Seiler, ELR Software Pty Ltd <http://www.elr.com.au>\r
-# Copyright 2005. License <http://creativecommons.org/licenses/LGPL/2.1/>\r
-\r
-package ParseMaster;\r
-use strict;\r
-use Data::Dumper;\r
-\r
-# Package wide variable declarations\r
-use vars qw/$VERSION\r
- @_X_escaped @_X_patterns\r
- /;\r
-\r
-$VERSION = '017';\r
-\r
-# constants\r
-my $X_EXPRESSION = 0;\r
-my $X_REPLACEMENT = 1;\r
-my $X_LENGTH = 2;\r
-\r
-# re's used to determine nesting levels\r
-my $X_GROUPS = qr/\(/o; # NB: Requires g modifier!\r
-my $X_SUB_REPLACE = qr/\$\d/o;\r
-my $X_INDEXED = qr/^\$\d+$/o;\r
-my $XX_ESCAPE = qr/\\./o; # NB: Requires g modifier!\r
-my $XX_DELETED = qr/\001[^\001]*\001/o; # NB: Requires g modifier!\r
-my $DIGIT = qr/[^\D]/o; # Yep - this is a digit - contains no non-digits\r
-\r
-# Constructor\r
-sub new {\r
- my $class = shift;\r
- my $self = {};\r
- @_X_escaped = (); # Re-initialize global for each instance\r
- @_X_patterns = (); # Re-initialize global for each instance\r
- # Instance variables - access by similarly named set/get functions\r
- $self->{_ignoreCase_} = 0;\r
- $self->{_escapeChar_} = '';\r
- bless ($self, $class);\r
- return $self;\r
-}\r
-\r
-sub ignoreCase {\r
- my ($self, $value) = @_;\r
- if (defined($value)) {\r
- $self->{_ignoreCase_} = $value;\r
- }\r
- return $self->{_ignoreCase_};\r
-}\r
-\r
-sub escapeChar{\r
- my ($self, $value) = @_;\r
- if (defined($value)) {\r
- $self->{_escapeChar_} = $value;\r
- }\r
- return $self->{_escapeChar_};\r
-}\r
-\r
-#######################\r
-# Public Parsemaster functions\r
-\r
-my $X_DELETE = sub(@$) {\r
- my $X_offset = pop;\r
- my @X_match = @_;\r
- return (chr(001) . $X_match[$X_offset] . chr(001));\r
-}; # NB semicolon required for closure!\r
-\r
-# create and add a new pattern to the patterns collection\r
-sub add {\r
- my ($self, $expression, $X_replacement) = @_;\r
- if (!$X_replacement) {$X_replacement = $X_DELETE};\r
-\r
- # count the number of sub-expressions\r
- my $temp = &_X_internalEscape($expression);\r
- my $length = 1; # Always at least one because each pattern is itself a sub-expression\r
- $length += $temp =~ s/$X_GROUPS//g; # One way to count the left capturing parentheses in the regexp string\r
-\r
- # does the pattern deal with sub-expressions?\r
- if ((ref($X_replacement) ne "CODE") && ($X_replacement =~ m/$X_SUB_REPLACE/)) {\r
- if ($X_replacement =~ m/$X_INDEXED/) { # a simple lookup? (eg "$2")\r
- # store the index (used for fast retrieval of matched strings)\r
- $X_replacement = substr($X_replacement,1) - 1;\r
- }\r
- else { # a complicated lookup (eg "Hello $2 $1")\r
- my $i = $length;\r
- while ($i) { # Had difficulty getting Perl to do Dean's splitting and joining of strings containing $'s\r
- my $str = '$a[$o+' . ($i-1) . ']'; # eg $a[$o+1]\r
- $X_replacement =~ s/\$$i/$str/; # eg $2 $3 -> $a[$o+1] $a[$o+2]\r
- $i--;\r
- }\r
- # build a function to do the lookup - returns interpolated string of array lookups\r
- $X_replacement = eval('sub {my $o=pop; my @a=@_; return "' . $X_replacement . '"};');\r
- }\r
- }\r
- else {}\r
- # pass the modified arguments\r
- &_X_add($expression || q/^$/, $X_replacement, $length);\r
-}\r
-\r
-# execute the global replacement\r
-sub exec {\r
-#print Dumper(@_X_patterns);\r
- my ($self, $X_string) = @_;\r
- my $escChar = $self->escapeChar();\r
- my $ignoreCase = $self->ignoreCase();\r
- my ($regexp,$captures) = &_getPatterns(); # Concatenated and parenthesized regexp eg '(regex1)|(regex2)|(regex3)' etc\r
- $X_string = &_X_escape($X_string, $escChar);\r
- if ($ignoreCase) {$X_string =~ s/$regexp/{&_X_replacement(&_matchVars($captures,\$X_string))}/gie} # Pass $X_String as a\r
- else {$X_string =~ s/$regexp/{&_X_replacement(&_matchVars($captures,\$X_string))}/ge} # reference for speed\r
-\r
- $X_string = &_X_unescape($X_string, $escChar);\r
- $X_string =~ s/$XX_DELETED//g;\r
- return $X_string;\r
-}\r
-\r
-sub _X_add {\r
- push (@_X_patterns, [@_]); # Save each argument set as is into an array of arrays\r
-}\r
-\r
-# this is the global replace function (it's quite complicated)\r
-sub _X_replacement {\r
- my (@arguments) = @_;\r
-#print Dumper (@arguments);\r
- if ($arguments[0] le '') {return ''}\r
- # Dereference last index (source String) here - faster than in _matchVars (maybe not needed at all?)\r
- $arguments[$#arguments] = ${$arguments[$#arguments]};\r
- my $i = 1;\r
- # loop through the patterns\r
- for (my $j=0; $j<scalar(@_X_patterns); $j++) { # Loop through global all @_X_patterns\r
- my @X_pattern = @{$_X_patterns[$j]};\r
- # do we have a result? NB: "if ($arguments[$i])" as in Dean's Javascript is false for the value 0!!!\r
- if ((defined $arguments[$i]) && ($arguments[$i] gt '')) {\r
- my $X_replacement = $X_pattern[$X_REPLACEMENT];\r
- # switch on type of $replacement\r
- if (ref($X_replacement) eq "CODE") { # function\r
- return &$X_replacement(@arguments,$i);\r
- }\r
- elsif ($X_replacement =~ m/$DIGIT/) { # number (contains no non-digits)\r
- return $arguments[$X_replacement + $i];\r
- }\r
- else { # default\r
- return $X_replacement; # default\r
- }\r
- } # skip over references to sub-expressions\r
- else {$i += $X_pattern[$X_LENGTH]}\r
- }\r
-}\r
-\r
-#######################\r
-# Private functions\r
-#######################\r
-\r
-# encode escaped characters\r
-sub _X_escape {\r
- my ($X_string, $X_escapeChar) = @_;\r
- if ($X_escapeChar) {\r
- my $re = '\\'.$X_escapeChar.'(.)';\r
- $X_string =~ s/$re/{push(@_X_escaped,$1); $X_escapeChar}/ge;\r
- }\r
- return $X_string;\r
-}\r
-\r
-# decode escaped characters\r
-sub _X_unescape {\r
- my ($X_string, $X_escapeChar) = @_;\r
- if ($X_escapeChar) { # We'll only do this if there is an $X_escapeChar!\r
- my $re = '\\'.$X_escapeChar;\r
- $X_string =~ s/$re/{$X_escapeChar . (shift(@_X_escaped))}/ge; # Don't use Dean Edwards as below 'or' here - because zero will return ''!\r
- # $X_string =~ s/$re/{$X_escapeChar . (shift(@_X_escaped) || '')}/ge;\r
- }\r
- return $X_string;\r
-}\r
-\r
-sub _X_internalEscape {\r
- my ($string) = shift;\r
- $string =~ s/$XX_ESCAPE//g;\r
- return $string;\r
-}\r
-\r
-# Builds an array of match variables to (approximately) emulate that available in Javascript String.replace()\r
-sub _matchVars {\r
- my ($m,$sref) = @_;\r
- my @args = (1..$m); # establish the number potential memory variables\r
- my @mv = map {eval("\$$_")} @args; # matchvarv[1..m] = the memory variables $1 .. $m\r
- unshift (@mv, $&); # matchvar[0] = the substring that matched\r
- push (@mv, length($`)); # matchvar[m+1] = offset within the source string where the match occurred (= length of prematch string)\r
- push (@mv, $sref); # matchvar[m+2] = reference to full source string (dereference in caller if/when needed)\r
-#print Dumper (@mv);\r
- return @mv;\r
-}\r
-\r
-sub _getPatterns {\r
- my @Patterns = ();\r
- my $lcp = 0;\r
- for (my $i=0; $i<scalar(@_X_patterns); $i++) { # Loop through global all @_patterns\r
- push (@Patterns, $_X_patterns[$i][$X_EXPRESSION]); # accumulate the expressions\r
- $lcp += $_X_patterns[$i][$X_LENGTH]; # sum the left capturing parenthesis counts\r
- }\r
- my $str = "(" . join(')|(',@Patterns). ")"; # enclose each pattern in () separated by "|"\r
- return ($str, $lcp);\r
-}\r
-\r
-##################\r
-# END #\r
-##################\r
-1; # ParseMaster #\r
-##################\r
git.asbjorn.biz / jquery.git / commitdiff