perl javascript packer

[vika]

Приветствую всех. Есть чудесная библиотека для упаковки  яваскрипта под названием JavaScript::Packer
А вот для распаковки автор что то не создал модуля, думала, может упаковщик и распаковывать сможет, а нет, в мане даже намека нету. На сайте автора упаковщика лежат какие исходники для perl, только они все датированы аж 2005 годом, не работают с новым перлом никак. Может кто то сталкивался с похожей проблемой, очень хотелось бы разобраться.

[RXL]

Ты смотрела, чем отличается "неупакованный" код от "упакованного"?
На этот случай online-упаковщик: http://dean.edwards.name/packer/

Ничего "чудесного" там нет. Просто удаляются все незначащие пробелы, переводы строк и комментарии. Соотв., обратное действие невозможно, но можно отформатировать код. Последняя фраза ключевая.

[vika]

Ты смотрела, чем отличается "неупакованный" код от "упакованного"?
На этот случай online-упаковщик: http://dean.edwards.name/packer/

Ничего "чудесного" там нет. Просто удаляются все незначащие пробелы, переводы строк и комментарии. Соотв., обратное действие невозможно, но можно отформатировать код. Последняя фраза ключевая.

Отличается пробелами (их удаляют) и перекодированием в base62. Что то нигде не нашла модуля для base62, есть только mime base64. А онлайн вариант не подойдет потому, что надо будет дергать за яйца какой нить онлайн сервис, что ни есть хорошо. Как вариант, был такой случай, в переменную получаю обфусцированный скрипт, шлю методом post в какую нибудь онлайн программу и также получаю готовый результат, но этот способ отпал сразу. Хочется решения на месте...

[RXL]

Одно слово в гугле и пару минут тыкания мышкой. Итог: исходники на PHP, JavaScript, Ruby, Python, newLISP.
http://snipplr.com/view/22246/
http://refactormycode.com/codes/125-base-62-encoding
http://hilocomod.blogspot.com/2010/03/base62-newlisp.html
http://marcus.bointon.com/archives/92-PHP-Base-62-encoding.html
https://github.com/jtzemp/base62/blob/master/lib/base62.rb

Только в чем смысл? Настройка gzip-сжатия на сервере даст сжатие раз в пять сильнее без извращений.

[vika]

Спасибо, но все же хотелось на перле. На других языках я знаю, что проще, но вся программа задумывается как перловая. А смысл в том, что нужно получить кусок html кода, распарсить его (что сделано), из распарсенного выражения вытащить нужное значение регекспом, предварителньо это выражение перегоняется из криптованного вида в нормальный вид, форматирование значения не имеет... Насколько я поняла, javascript компрессор просто скрипт перегоняет в кодировку base62. Сколько самописных вариантов не видела, все или не работают или только кодируют в base62, без раскодирования. Жаль, что нет готового модуля, вроде mime base64, чтобы можно было его заюзать.

[RXL]

vika, там пять строчек. На perl это не будет длиннее. Или ты ищешь халяву?

Пройдись по моим ссылкам. Декодировщики там приведены.
Первая же ссылка: http://snipplr.com/view/22246/
Кодировщик и декодировщик. Синтаксис PHP на этих примерах на 99% совместим с Perl. Кардинальное различие лишь в массивах и функциях.

Добавлено через 20 минут и 27 секунд:
Приведи фрагмент "сжатого" JavaScript.

[vika]

Код:

eval(function(p,a,c,k,e,r){e=function(c){return(c<a?'':e(parseInt(c/a)))+((c=c%a)>35?String.fromCharCode(c+29):c.toString(36))};if(!''.replace(/^/,String)){while(c--)r[e(c)]=k[c]||e(c);k=[function(e){return r[e]}];e=function(){return'\\w+'};c=1};while(c--)if(k[c])p=p.replace(new RegExp('\\b'+e(c)+'\\b','g'),k[c]);return p}('<!--l--><m c="x-y"><n z="0"A="0"8="B%"><o><6 h="C"9="8:D;"><a 4="./E.2"><b>Главная</b></a>&;<a 4="p.2"><b>Трекер</b></a>&;<a 4="5.2"><b>Поиск</b></a>&;<a 4="F.2"><b>Правила</b></a>&;<a 4="G.2?H=I&J=K"L="M.N(7.4, \'\', O); q P;"><b>ПользовательскоеСоглашение</b></a>&;<a 4="Q.2"><b 9="R: #S;">T</b></a>&;<a 4="U.2"><b>Группы</b></a>&;<a 4="V.2"><b>Пользователи</b></a></6><6>&W;</6><6 9="8:X;"><r c="Y-5"d=""Z="10"11="$(7).12(\'d\', $(\'#5-d\').s());13 i=$(\'#5-j\').s(); q !(i==\'поиск...\' || !i);"><e f="t"k="14"3="1"><e f="t"k="15"3="1"><e c="5-j"f="j"k="16"17="u(7.3==\'поиск...\') 7.3=\'\';"18="u(7.3==\'\') 7.3=\'поиск...\';"3="поиск..."h="19"9="8: 1a;"><v c="5-d"><g 3="p.2#1b"w="w">потрекеру</g><g 3="5.2">пофоруму</g></v><e f="1c"h="1d 1e"3="&1f;"9="8: 1g;"></r></6></o></n></m><!--/l-->',62,79,'||php|value|href|search|td|this|width|style|||id|action|input|type|option|class|txt|text|name|main_nav|div|table|tr|tracker|return|form|val|hidden|if|select|selected|main|nav|cellpadding|cellspacing|100|nowrap|600px|index|rules|misc|do|info|show|user_agreement|onclick|window|open|InfoWinParams|false|faq|color|993300|FAQ|groupcp|memberlist|nbsp|300px|quick|method|post|onsubmit|attr|var|max|to|nm|onfocus|onblur|hint|120px|results|submit|med|bold|raquo|30px'.split('|'),0,{}))

[Sla]

Да уж
Кто будет на стороне перла js eval выполнять?

[vika]

Да уж
Кто будет на стороне перла js eval выполнять?

А зачем его выполнять? Просто перевести в массив данных html и выудить нужную информацию. Js Compressor ведь по такому принципу работает, переводит в кодировку base62 и обрезает пробелы, там, где можно

[RXL]

Разложил для повышения читаемости.

Код: (Javascript)

1. eval(
2.     function (p, a, c, k, e, r)
3.     {
4.         e = function(c)
5.         {
6.             return
7.                 (
8.                     c < a
9.                         ? ''
10.                         : e(parseInt(c / a))
11.                 )
12.                 + (
13.                     (c = c % a) > 35
14.                         ? String.fromCharCode(c + 29)
15.                         : c.toString(36)
16.                 )
17.         };
18.  
19.         if (! ''.replace(/^/, String))
20.         {
21.             while (c--)
22.                 r[e(c)] = k[c] || e(c);
23.  
24.             k = [ function(e) { return r[e] } ];
25.  
26.             e = function()
27.             {
28.                 return '\\w+'
29.             };
30.  
31.             c = 1
32.         };
33.  
34.         while (c--)
35.             if (k[c])
36.                 p = p.replace(
37.                     new RegExp('\\b' + e(c) + '\\b', 'g'),
38.                     k[c]
39.                 );
40.  
41.         return p
42.     }
43.     (
44.         '<!--l--><m c="x-y"><n z="0"A="0"8="B%"><o><6 h="C"9="8:D;"><a 4="./E.2"><b>Главная</b></a>&;<a 4="p.2"><b>Трекер</b></a>&;<a 4="5.2"><b>Поиск</b></a>&;<a 4="F.2"><b>Правила</b></a>&;<a 4="G.2?H=I&J=K"L="M.N(7.4, \'\', O); q P;"><b>ПользовательскоеСоглашение</b></a>&;<a 4="Q.2"><b 9="R: #S;">T</b></a>&;<a 4="U.2"><b>Группы</b></a>&;<a 4="V.2"><b>Пользователи</b></a></6><6>&W;</6><6 9="8:X;"><r c="Y-5"d=""Z="10"11="$(7).12(\'d\', $(\'#5-d\').s());13 i=$(\'#5-j\').s(); q !(i==\'поиск...\' || !i);"><e f="t"k="14"3="1"><e f="t"k="15"3="1"><e c="5-j"f="j"k="16"17="u(7.3==\'поиск...\') 7.3=\'\';"18="u(7.3==\'\') 7.3=\'поиск...\';"3="поиск..."h="19"9="8: 1a;"><v c="5-d"><g 3="p.2#1b"w="w">потрекеру</g><g 3="5.2">пофоруму</g></v><e f="1c"h="1d 1e"3="&1f;"9="8: 1g;"></r></6></o></n></m><!--/l-->',
45.         62,
46.         79,
47.         '||php|value|href|search|td|this|width|style|||id|action|input|type|option|class|txt|text|name|main_nav|div|table|tr|tracker|return|form|val|hidden|if|select|selected|main|nav|cellpadding|cellspacing|100|nowrap|600px|index|rules|misc|do|info|show|user_agreement|onclick|window|open|InfoWinParams|false|faq|color|993300|FAQ|groupcp|memberlist|nbsp|300px|quick|method|post|onsubmit|attr|var|max|to|nm|onfocus|onblur|hint|120px|results|submit|med|bold|raquo|30px'.split('|'),
48.         0,
49.         {}
50.     )
51. )

Да, черт ногу сломит, но невозможного тут нет.


Добавлено через 1 минуту и 40 секунд:
vika, ты ошибаешься. Base62 тут не пахнет. Посмотри на входные данные (строки 44 и 47).

[vika]

Странно, что в перле нет ничего, чтобы с base62 работать. Имеющиеся коды написаны на коленке, причем непонятно кем, даже руководства не найти, не поймешь, что делать надо, откуда что взято...

Добавлено через 2 минуты и 6 секунд:
Так у самого разработчика этого пакера есть форма, там прямо указано, как преобразуется скрипт http://dean.edwards.name/packer/ (base62 и обрезание)

[RXL]

К примеру,

Код: (Javascript)

    function (p, a, c, k, e, r)
    {
...........
    }
    (
        '<!--l-->......<!--/l-->',
        62,
        79,
        '||php|value|......|raquo|30px'.split('|'),
        0,
        {}
    )

означает

Код: (Javascript)

p = '<!--l-->......<!--/l-->'
a = 62
c = 79
k = '||php|value|......|raquo|30px'.split('|')
e = 0
r = {}

и оформлено так чисто для антуража, т.к. занимает больше места, чем читаемая запись.


Добавлено через 3 минуты и 40 секунд:
vika, задай себе вопрос: что такое "base62"? Только ответив на него будешь знать, нужно ли оно тебе и как его получить.

[vika]

base 62 это способ кодировки информации, как например base64, md5 и т.п. Вот, думаю, заюзать что ли модуль JavaScript.
Надо же как-то раскодировать данную околесицу. Тем более, что большинство онлайн кодеров/декодеров все это дело понимают и раскодировать могут без проблем. Какой то алгоритм все-таки есть, не с потолка же это взято.

[RXL]

vika, "способ кодировки информации" - это также и Морзянка. Может она тебе нужна?
Я намекаю, что на вопрос ты не ответила.

[vika]

vika, "способ кодировки информации" - это также и Морзянка. Может она тебе нужна?
Я намекаю, что на вопрос ты не ответила.

Ну, то что это не морзянка, я думаю и так видно.  А как перефразировать, я не знаю, женский ум тут значительно уступает мужскому, потому и обратилась за помощью к толковым людям.

[RXL]

Нежелание напрягать голову - это плохо, но половую дифференциацию сюда прикладывать не надо.

Код: (Perl)

# JScript function "_unpack" - from DeanEdwards pack.js (NB: No ";" after final "}")
($_JSunpack) = <<'END_JSCRIPT_UNPACK';
/* unpacking function - this is the boot strap function   */
/* data extracted from this packing routine is passed to  */
/* this function when decoded in the target               */
function($packed, $ascii, $count, $keywords, $encode, $decode) {
  while ($count--)
    if ($keywords[$count])
     $packed = $packed.replace(new RegExp('\\b' + $encode($count) + '\\b', 'g'), $keywords[$count]);
  /* RS_Debug = $packed; */  /* {RS} !!!!!!!!! */
  return $packed;
}
END_JSCRIPT_UNPACK

# JScript function "_decode" - from DeanEdwards pack.js
($_JSdecode) = <<'END_JSCRIPT_DECODE';
  /* code-snippet inserted into the unpacker to speed up decoding */
  function() {
    /* does the browser support String.replace where the */
    /*  replacement value is a function? */
    if (!''.replace(/^/, String)) {
      /* decode all the values we need */
          while ($count--) $decode[$encode($count)] = $keywords[$count] || $encode($count);
          /* global replacement function */
          $keywords = [function($encoded){return $decode[$encoded]}];
          /* generic match */
          $encode = function(){return'\\w+'};
          /* reset the loop counter -  we are now doing a global replace */
          $count = 1;
      }
  };
END_JSCRIPT_DECODE

# JScript versions of encoders
($_JSencode10) = <<'END_JSCRIPT_ENCODE10';
  /* zero encoding */
  /* characters: 0123456789 */
  function($charCode) {
    return $charCode;
  };
END_JSCRIPT_ENCODE10

($_JSencode36) = <<'END_JSCRIPT_ENCODE36';
  /* inherent base36 support */
  /* characters: 0123456789abcdefghijklmnopqrstuvwxyz */
  function($charCode) {
    return $charCode.toString(36);
  };
END_JSCRIPT_ENCODE36

($_JSencode62) = <<'END_JSCRIPT_ENCODE62';
  /* hitch a ride on base36 and add the upper case alpha characters */
  /* characters: 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ */
  function($charCode) {
    return ($charCode < _encoding ? '' : arguments.callee(parseInt($charCode / _encoding))) +
    (($charCode = $charCode % _encoding) > 35 ? String.fromCharCode($charCode + 29) : $charCode.toString(36));
   };
END_JSCRIPT_ENCODE62

($_JSencode95) = <<'END_JSCRIPT_ENCODE95';
 /* use high-ascii values */
 /* characters: ЎўЈ¤Ґ¦§Ё©Є«¬­®Ї°±Ііґµ¶·ё№є»јЅѕїАБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдежзийклмнопрстуфхцчшщъыьэю */
 function($charCode) {
   return ($charCode < _encoding ? '' : arguments.callee($charCode / _encoding)) +
     String.fromCharCode($charCode % _encoding + 161);
 };
END_JSCRIPT_ENCODE95

Прилагается к perl-коду. Надо было только посмотреть. Модуль Pack.pm.

Теперь дешефрация должна быть проще. Попробуй...

[Sla]

ну на самом деле я думаю, что там будет что-то типа document.write
а далее html код
строчки указанные RXL

просто буква поставлена в соответствие  "словарю"

[vika]

Спасибо, тольо этот вариант уже пробовался мною, в результате не работает потому, что требует недостающие библиотеки, устанавливала недостающие библиотеки, требует переустановить перл на версию, более страую, чем установленная (acriveperl 5.14.2)

[RXL]

vika, ты хоть пытаешься понять, что я тебе пишу? Там автор даже комментарии оставил.

[vika]

Вот, что мне выдается

Код:

Panic: Some symbols not resolvable from C:\packer2.perl\perl56.dll

[RXL]

Оставь perl и этот модуль в покое. Просто читай написанное. Ничего запускать не надо.

Добавлено через 6 минут и 43 секунды:
Итог:

Код: (Javascript)

function unpack($packed, $count, $keywords) {
    while ($count--)
        if ($keywords[$count])
             $packed = $packed.replace(new RegExp('\\b' + $encode($count) + '\\b', 'g'), $keywords[$count]);
    return $packed;
}

function decode() {
    if (!''.replace(/^/, String)) {
        while ($count--) $decode[$encode($count)] = $keywords[$count] || $encode($count);
        $keywords = [function($encoded){return $decode[$encoded]}];
        $encode = function(){return'\\w+'};
        $count = 1;
    }
};

function encode($charCode) {
    return ($charCode < _encoding ? '' : arguments.callee(parseInt($charCode / _encoding))) +
        (($charCode = $charCode % _encoding) > 35 ? String.fromCharCode($charCode + 29) : $charCode.toString(36));
};

_encoding = 62;
unpack(packed, count, keywords);

Это не Perl! Ничего не надо запускать!  

[vika]

А как тогда распаковать то? Что то совсем ничего не понятно. Я думала, что это просто модуль, который надо подключить в свой скрипт.

[RXL]

Скучно с тобой. Я то думал, ты хочешь разобраться и чему-то научиться. Выходит, что ты просто ищешь, кто за тебя сделает.

[vika]

Конечно хочу, а вы говорите загадками. Если это способ распаковать локально обфусцированный скрипт, то он не представляет для меня интереса, как уже было сказано, я нуждаюсь в решении именно на perl. Вот, в чем проблема.

[RXL]

Скажешь тоже — загадками! Ведь ты же не читаешь, что я тебе пишу.

[vika]

Я правильно поняла, что в perl это раскодировать нельзя? Ну, т.е., из этой абракадабры получить html код, неважно, с отступами или без? Как я уже говорила, мои рассуждения строились на том, что включив модуль pack.pm, можно в своем скрипте реализовать распознавание этого зашифрованного куска.

[RXL]

vika, ты практически все неправильно поняла.
Модуль Pack.pm (регистр имеет значение!) не предназначен для распаковки, а только для упаковки. Но внутри него содержится хорошо читаемый и комментированный код для JavaScript, с помощью которого можно распаковать. Я приводил его выше. Тебе нужно разобрать алгоритм и реализовать его на Perl или другом, подходящем тебе языке.

[vika]

Ну вот, теперь доходчиво и понятно. Спасибо. Будем пробовать...

[vika]

Собственно, уже тему создавала похожу, но теперь приперло. Приветствую всех. Есть пакер на яваскрипт, вот он http://dean.edwards.name/packer/
Для перла сделан модуль, чтобы запаковывать, а вот распаковки что то автор порта на перл не сделал. Собственно, лог. подумав, пришла к выводу, что если есть алгоритм упаковки, то можно и распаковку сделать аналогично, но что то никак не соображу. Просьба подсказать, как действовать, ибо там столько всего намудрено, голова кругом идет.

Код: (Perl)

#Pack (July 2005)
#  Based on "Pack.js" by Dean Edwards <http://dean.edwards.name/>
#  Ported to Perl by Rob Seiler, ELR Software Pty Ltd <http://www.elr.com.au>
#  Copyright 2005. License <http://creativecommons.org/licenses/LGPL/2.1/>

package Pack;
use strict;
use Data::Dumper;

use ParseMaster;

# Package wide variable declarations
use vars qw/$VERSION $PM_VERSION
            $_X_encodePrivate $_JSunpack $_JSdecode %baseLookup
            $_X_encode10 $_X_encode36 $_X_encode62 $_X_encode95
            $_JSencode10 $_JSencode36 $_JSencode62 $_JSencode95
            @_X_parsers
            $_X_script $_X_encoding $_X_fastDecode $_X_specialChars
           /;
$VERSION    = '024';
$PM_VERSION = $ParseMaster::VERSION;

# Package wide constants
my $X_IGNORE  = q{$1};
my $X_ENCODE  = q/\x24encode\(\x24count\)/;  # NB: requires g modifier
my $PERL      = 'perl';     # Flag to indicate whether we need to use one of our "internal" Perl encoding functions
my $JSCRIPT   = 'jscript';  # or embed a pre-build JScript encoding function
########################################

##################
sub pack($$$$) { # require 4 arguments
##################
#print Dumper(@_);
  ($_X_script, $_X_encoding, $_X_fastDecode, $_X_specialChars) = @_;
  # validate parameters (sort of!)
  $_X_script  .= "\n";
  $_X_encoding = ($_X_encoding > 95) ? 95 : $_X_encoding;

  @_X_parsers = (); # Reset parsers

####################
  sub _X_pack($) { # require 1 argument
####################
  # apply all parsing routines
    my $X_script = shift;
    for (my $i = 0; $i<scalar(@_X_parsers); $i++) {
      my $X_parse = $_X_parsers[$i];
       $X_script = &$X_parse($X_script);
    }
    return $X_script;
  };

######################
  sub _X_addParser { #
######################
  # keep a list of parsing functions, they'll be executed all at once
    my $X_parser = shift;
    push (@_X_parsers,$X_parser);
  }

#############################
  sub _X_basicCompression { #
#############################
    # zero encoding - just removal of white space and comments
    my $X_script = shift;
    my $parser = ParseMaster->new();
    # make safe
    $parser->escapeChar("\\");
    # protect strings
    $parser->add(q/'[^'\n\r]*'/, $X_IGNORE);
    $parser->add(q/"[^"\n\r]*"/, $X_IGNORE);
    # remove comments
    $parser->add(q/\/\/[^\n\r]*[\n\r]/);
    $parser->add(q/\/\*[^*]*\*+([^\/][^*]*\*+)*\//);
    # protect regular expressions
    $parser->add(q/\s+(\/[^\/\n\r\*][^\/\n\r]*\/g?i?)/, q{$2}); # IGNORE
    $parser->add(q/[^\w\x24\/'"*)\?:]\/[^\/\n\r\*][^\/\n\r]*\/g?i?/, $X_IGNORE);
    # remove: ;;; doSomething();
    $parser->add(q/;;[^\n\r]+[\n\r]/) if ($_X_specialChars);
    # remove redundant semi-colons
    $parser->add(q/;+\s*([};])/, q{$2});
    # remove white-space
    $parser->add(q/(\b|\x24)\s+(\b|\x24)/, q{$2 $3});
    $parser->add(q/([+\-])\s+([+\-])/, q{$2 $3});
    $parser->add(q/\s+/, '');
    # done
    return $parser->exec($X_script);
  }

###############################
  sub _X_encodeSpecialChars { #
###############################
    my $X_script = shift;
    my $parser = ParseMaster->new();
    # replace: $name -> n, $$name -> $$na
    $parser->add(q/((\x24+)([a-zA-Z\x24_]+))(\d*)/,
      sub {
        my $X_offset   = pop;
        my @X_match    = @_;
        my $X_length   = length($X_match[$X_offset+2]);
        my $lengthnext = length($X_match[$X_offset+3]);
        my $X_start = $X_length - ((($X_length - $lengthnext) > 0) ? ($X_length - $lengthnext) : 0);
        my $str = $X_match[$X_offset+1];
        $str = substr($str,$X_start,$X_length) . $X_match[$X_offset+4];
        return "$str";
      });
     # replace: _name -> _0, double-underscore (__name) is ignored
     my $X_regexp = q/\b_[A-Za-z\d]\w*/;
     # build the word list
     my %X_keywords = &_X_analyze($X_script, $X_regexp, $_X_encodePrivate);
#print Dumper(%X_keywords);
     # quick ref
     my $X_encoded = \$X_keywords{X_encoded}; # eg _private1 => '_0',_private2 => '_1';
#print Dumper($X_encoded);
     $parser->add($X_regexp, sub {my $X_offset = pop; my @X_match = @_; return ${$X_encoded}->{$X_match[$X_offset]};});

     return $parser->exec($X_script);
  };

###########################
  sub _X_encodeKeywords { #
###########################
    my $X_script = shift;
    # escape high-ascii values already in the script (i.e. in strings)
    if ($_X_encoding > 62) {$X_script = &_X_escape95($X_script)};
    # create the parser
    my $parser = ParseMaster->new();
    my $X_encode = &_X_getEncoder($_X_encoding,$PERL);
    # for high-ascii, don't encode single character low-ascii
    my $X_regexp = ($_X_encoding > 62) ? q/\w\w+/ : q/\w+/;
    # build the word list
    my %X_keywords = &_X_analyze($X_script, $X_regexp, $X_encode);
#print Dumper(%X_keywords);
    my $X_encoded = \$X_keywords{X_encoded}; # eg alert => 2, function => 10 etc
    # encode
    $parser->add($X_regexp, sub {my $X_offset = pop; my @X_match = @_; return ${$X_encoded}->{$X_match[$X_offset]};});
    # if encoded, wrap the script in a decoding function

    return $X_script && _X_bootStrap(\$parser->exec($X_script), \%X_keywords);
  }

####################
  sub _X_analyze { #
####################
#print Dumper(@_);
    my ($X_script, $X_regexp, $X_encode) = @_;
    # analyse
    # retreive all words in the script
    my @X_all = $X_script =~ m/$X_regexp/g; # Save all captures in a list context
    my %XX_sorted    = ();  # list of words sorted by frequency
    my %XX_encoded   = ();  # dictionary of word->encoding
    my %XX_protected = ();  # instances of "protected" words
    if (@X_all) {
      my @X_unsorted  = (); # same list, not sorted
      my %X_protected = (); # "protected" words (dictionary of word->"word")
      my %X_values    = (); # dictionary of charCode->encoding (eg. 256->ff)
      my %X_count     = (); # word->count
      my $i = scalar(@X_all); my $j = 0; my $X_word = '';
      # count the occurrences - used for sorting later
      do {
        $X_word = '$' . $X_all[--$i];
        if (!exists($X_count{$X_word})) {
          $X_count{$X_word}   = [0,$i]; # Store both the usage count and original array position (ie a secondary sort key)
          $X_unsorted[$j]   = $X_word;
          # make a dictionary of all of the protected words in this script
          #   these are words that might be mistaken for encoding
          $X_values{$j}     = &$X_encode($j);
          my $v           = '$'.$X_values{$j};
          $X_protected{$v}  = $j++;
        }
        # increment the word counter
        $X_count{$X_word}[0]++;
      } while ($i);
#print Dumper (%X_values);
#print Dumper (@X_unsorted);
#print Dumper (%X_protected);
      # prepare to sort the word list, first we must protect
      #  words that are also used as codes. we assign them a code
      #  equivalent to the word itself.
      # e.g. if "do" falls within our encoding range
      #       then we store keywords["do"] = "do";
      # this avoids problems when decoding
       $i = scalar(@X_unsorted);
      do {
        $X_word = $X_unsorted[--$i];
        if (exists($X_protected{$X_word})) {
          $XX_sorted{$X_protected{$X_word}} = substr($X_word,1);
          $XX_protected{$X_protected{$X_word}} = 1; # true
          $X_count{$X_word}[0] = 0;
        }
      } while ($i);
#print Dumper (%XX_protected);
#print Dumper (%XX_sorted);
#print Dumper (%X_count);
      # sort the words by frequency
      # Sort with count a primary key and original array order as secondary key - which is apparently the default in javascript!
      @X_unsorted = sort ({($X_count{$b}[0] - $X_count{$a}[0]) or ($X_count{$b}[1] <=> $X_count{$a}[1])} @X_unsorted);
#print Dumper (@X_unsorted) . "\n";

      $j = 0;
      # because there are "protected" words in the list
      # we must add the sorted words around them
      do {
        if (!exists($XX_sorted{$i})) {$XX_sorted{$i} = substr($X_unsorted[$j++],1)}
        $XX_encoded{$XX_sorted{$i}} = $X_values{$i};
      } while (++$i < scalar(@X_unsorted));
    }
#print Dumper(X_sorted => \%XX_sorted, X_encoded => \%XX_encoded, X_protected => \%XX_protected);
    return (X_sorted => \%XX_sorted, X_encoded => \%XX_encoded, X_protected => \%XX_protected);
  }

######################
  sub _X_bootStrap { #
######################
    # build the boot function used for loading and decoding
    my ($X_packed, $X_keywords) = @_; # Reference arguments!
#print Dumper ($X_keywords) . "\n";

    # $packed: the packed script - dereference and escape
    $X_packed = "'" . &_X_escape($$X_packed) ."'";

    my %sorted    = %{$$X_keywords{X_sorted}};    # Dereference to local variables
    my %protected = %{$$X_keywords{X_protected}}; # for simplicity

    my @sorted    = ();
    foreach my $key (keys %sorted) {$sorted[$key] = $sorted{$key}}; # Convert hash to a standard list

    # ascii: base for encoding
    my $X_ascii = ((scalar(@sorted) > $_X_encoding) ? $_X_encoding : scalar(@sorted)) || 1;

    # count: number of (unique {RS}) words contained in the script
    my $X_count = scalar(@sorted); # Use $X_count for assigning $X_ascii

    # keywords: list of words contained in the script
    foreach my $i (keys %protected) {$sorted[$i] = ''}; # Blank out protected words
#print Dumper(@sorted) . "\n";

    # convert from a string to an array - prepare keywords as a JScript string->array {RS}
    $X_keywords = "'" . join('|',@sorted) . "'.split('|')";

    # encode: encoding function (used for decoding the script)
    my $X_encode = $_X_encoding > 62 ? $_JSencode95 : &_X_getEncoder($X_ascii,$JSCRIPT); # This is a JScript function (as a string)
       $X_encode =~ s/_encoding/\x24ascii/g; $X_encode =~ s/arguments\.callee/\x24encode/g;
    my $X_inline = '$count' . ($X_ascii > 10 ? '.toString($ascii)' : '');

    # decode: code snippet to speed up decoding
    my $X_decode = '';
    if ($_X_fastDecode) {
      # create the decoder
      $X_decode = &_X_getFunctionBody($_JSdecode); # ie from the Javascript literal function
      if ($_X_encoding > 62) {$X_decode =~ s/\\\\w/[\\xa1-\\xff]/g}
      # perform the encoding inline for lower ascii values
      elsif ($X_ascii < 36) {$X_decode =~ s/$X_ENCODE/$X_inline/g}
      # special case: when $X_count==0 there ar no keywords. i want to keep
      # the basic shape of the unpacking funcion so i'll frig the code...
      if (!$X_count) {$X_decode =~ s/(\x24count)\s*=\s*1/$1=0/}
    }

    # boot function
    my $X_unpack = $_JSunpack;
    if ($_X_fastDecode) {
      # insert the decoder
      $X_unpack =~ s/\{/\{$X_decode;/;
    }
    $X_unpack =~ s/"/'/g;
    if ($_X_encoding > 62) { # high-ascii
      # get rid of the word-boundaries for regexp matches
      $X_unpack =~ s/'\\\\b'\s*\+|\+\s*'\\\\b'//g; # Not checked! {RS}
    }
    if ($X_ascii > 36 || $_X_encoding > 62 || $_X_fastDecode) {
    # insert the encode function
    $X_unpack =~ s/\{/\{\$encode=$X_encode;/;
    } else {
      # perform the encoding inline
      $X_unpack =~ s/$X_ENCODE/$X_inline/;
    }

    # arguments   {RS} Do this before using &pack because &pack changes the pack parameters (eg $fastDecode) in Perl!!
    my $X_params = "$X_packed,$X_ascii,$X_count,$X_keywords"; # Interpolate to comma separated string
    if ($_X_fastDecode) {
      # insert placeholders for the decoder
      $X_params .= ',0,{}';
    }

    # pack the boot function too
    $X_unpack = &pack($X_unpack,0,0,1);

    # the whole thing
    return "eval(" . $X_unpack . "(" . $X_params . "))\n";
  };

#######################
  sub _X_getEncoder { #
#######################
  # mmm.. ..which one do i need ?? ({RS} Perl or JScript ??)
    my ($X_ascii,$language) = @_;
    my $perl_encoder    = ($X_ascii > 10) ? ($X_ascii > 36) ? ($X_ascii > 62) ? $_X_encode95 : $_X_encode62 : $_X_encode36 : $_X_encode10;
    my $jscript_encoder = ($X_ascii > 10) ? ($X_ascii > 36) ? ($X_ascii > 62) ? $_JSencode95 : $_JSencode62 : $_JSencode36 : $_JSencode10;
    return ($language eq $JSCRIPT) ? $jscript_encoder : $perl_encoder;
  };

#############################
# Perl versions of encoders #
#############################
  # base10 zero encoding - characters: 0123456789
  $_X_encode10 = sub {return &_encodeBase(shift,10)};
  # base36               - characters: 0123456789abcdefghijklmnopqrstuvwxyz
  $_X_encode36 = sub {return &_encodeBase(shift,36)};
  # base62               - characters: 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ
  $_X_encode62 = sub {return &_encodeBase(shift,62)};
  # high-ascii values    - characters: ЎўЈ¤Ґ¦§Ё©Є«¬­®Ї°±Ііґµ¶·ё№є»јЅѕїАБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдежзийклмнопрстуфхцчшщъыьэю
  $_X_encode95 = sub {return &_encodeBase(shift,95)};
  # Lookup character sets for baseN encoding
     $baseLookup{10} = [(0..9)[0..9]];                    # base 10
     $baseLookup{36} = [(0..9,'a'..'z')[0..35]];          # base 36
     $baseLookup{62} = [(0..9,'a'..'z','A'..'Z')[0..61]]; # base 62
     $baseLookup{95} = (); for (my $i=0; $i<95; $i++) {$baseLookup{95}[$i] = chr($i+161)}; # base95 (high ascii)
#print Dumper(%baseLookup);
#####################
  sub _encodeBase { #
#####################
  # Generic base conversion function using defined lookup arrays (perl version only)
    my ($X_charCode, $base) = @_;
    my $X_encoded = '';
    # Do we know this encoding?
    if (exists ($baseLookup{$base})) {
      if ($X_charCode == 0) {$X_encoded = $baseLookup{$base}[0]}
      while($X_charCode > 0) {
        $X_encoded  = $baseLookup{$base}[$X_charCode % $base] . $X_encoded;
        $X_charCode = int($X_charCode / $base);
      }
    }
    else {$X_encoded = "$X_charCode"} # default is to return unchanged (ie as for base 10) if no baselookup is available
    return $X_encoded;
  };

#############################
  $_X_encodePrivate = sub { #
#############################
  # special _chars
    my $X_charCode = shift;
    return '_' . $X_charCode;
  };

############################
  sub _X_escape($script) { #
############################
  # protect characters used by the parser
    my $X_script = shift;
    $X_script =~ s/([\\'])/\\$1/g;
    return $X_script;
  };

#####################
  sub _X_escape95 { #
#####################
  # protect high-ascii characters already in the script
    my $X_script = shift;
    $X_script =~ s/([\xa1-\xff])/sprintf("\\x%1x",ord($1))/eg;
    return $X_script;
  };

############################
  sub _X_getFunctionBody { #
############################
  # extract the body of a function (ie between opening/closing {}) - consistent with Dean Edwards approach
    my $X_function = shift;
    $X_function =~ m/^.*\{(.*)\}*$/sg; # Multiline, global (greedy)
    my $start = index($X_function,'{');
    my $end   = rindex($X_function,'}');
    $X_function = substr($X_function,($start+1),($end-1-$start));
    return $X_function;
  };

######################
  sub _X_globalize { #
######################
  # set the global flag on a RegExp (you have to create a new one) !!! Unused in perl version
    # my $X_regexp = shift;
  };

  # build the parsing routine
  &_X_addParser(\&_X_basicCompression);
  &_X_addParser(\&_X_encodeSpecialChars) if ($_X_specialChars);
  &_X_addParser(\&_X_encodeKeywords)     if ($_X_encoding);

  # go!
  return &_X_pack($_X_script);
}

########################
# Javascript Literals  #
########################

# JScript function "_unpack" - from DeanEdwards pack.js (NB: No ";" after final "}")
($_JSunpack) = <<'END_JSCRIPT_UNPACK';
/* unpacking function - this is the boot strap function   */
/* data extracted from this packing routine is passed to  */
/* this function when decoded in the target               */
function($packed, $ascii, $count, $keywords, $encode, $decode) {
  while ($count--)
    if ($keywords[$count])
     $packed = $packed.replace(new RegExp('\\b' + $encode($count) + '\\b', 'g'), $keywords[$count]);
  /* RS_Debug = $packed; */  /* {RS} !!!!!!!!! */
  return $packed;
}
END_JSCRIPT_UNPACK

# JScript function "_decode" - from DeanEdwards pack.js
($_JSdecode) = <<'END_JSCRIPT_DECODE';
  /* code-snippet inserted into the unpacker to speed up decoding */
  function() {
    /* does the browser support String.replace where the */
    /*  replacement value is a function? */
    if (!''.replace(/^/, String)) {
      /* decode all the values we need */
          while ($count--) $decode[$encode($count)] = $keywords[$count] || $encode($count);
          /* global replacement function */
          $keywords = [function($encoded){return $decode[$encoded]}];
          /* generic match */
          $encode = function(){return'\\w+'};
          /* reset the loop counter -  we are now doing a global replace */
          $count = 1;
      }
  };
END_JSCRIPT_DECODE

# JScript versions of encoders
($_JSencode10) = <<'END_JSCRIPT_ENCODE10';
  /* zero encoding */
  /* characters: 0123456789 */
  function($charCode) {
    return $charCode;
  };
END_JSCRIPT_ENCODE10

($_JSencode36) = <<'END_JSCRIPT_ENCODE36';
  /* inherent base36 support */
  /* characters: 0123456789abcdefghijklmnopqrstuvwxyz */
  function($charCode) {
    return $charCode.toString(36);
  };
END_JSCRIPT_ENCODE36

($_JSencode62) = <<'END_JSCRIPT_ENCODE62';
  /* hitch a ride on base36 and add the upper case alpha characters */
  /* characters: 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ */
  function($charCode) {
    return ($charCode < _encoding ? '' : arguments.callee(parseInt($charCode / _encoding))) +
    (($charCode = $charCode % _encoding) > 35 ? String.fromCharCode($charCode + 29) : $charCode.toString(36));
   };
END_JSCRIPT_ENCODE62

($_JSencode95) = <<'END_JSCRIPT_ENCODE95';
 /* use high-ascii values */
 /* characters: ЎўЈ¤Ґ¦§Ё©Є«¬­®Ї°±Ііґµ¶·ё№є»јЅѕїАБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдежзийклмнопрстуфхцчшщъыьэю */
 function($charCode) {
   return ($charCode < _encoding ? '' : arguments.callee($charCode / _encoding)) +
     String.fromCharCode($charCode % _encoding + 161);
 };
END_JSCRIPT_ENCODE95

###########
# END     #
###########
1; # Pack #
###########

Неясно, правда, что ParseMaster.pm делает

Код: (Perl)

#ParseMaster (July 25 2005)
#  Based on "ParseMaster.js" by Dean Edwards <http://dean.edwards.name/>
#  Ported to Perl by Rob Seiler, ELR Software Pty Ltd <http://www.elr.com.au>
#  Copyright 2005. License <http://creativecommons.org/licenses/LGPL/2.1/>

package ParseMaster;
use strict;
use Data::Dumper;

# Package wide variable declarations
use vars qw/$VERSION
            @_X_escaped @_X_patterns
           /;

$VERSION    = '017';

# constants
my $X_EXPRESSION  = 0;
my $X_REPLACEMENT = 1;
my $X_LENGTH      = 2;

# re's used to determine nesting levels
my $X_GROUPS      = qr/\(/o;                # NB: Requires g modifier!
my $X_SUB_REPLACE = qr/\$\d/o;
my $X_INDEXED     = qr/^\$\d+$/o;
my $XX_ESCAPE     = qr/\\./o;               # NB: Requires g modifier!
my $XX_DELETED    = qr/\001[^\001]*\001/o;  # NB: Requires g modifier!
my $DIGIT         = qr/[^\D]/o;             # Yep - this is a digit - contains no non-digits

# Constructor
sub new {
  my $class = shift;
  my $self  = {};
  @_X_escaped  = ();  # Re-initialize global for each instance
  @_X_patterns = ();  # Re-initialize global for each instance
  # Instance variables - access by similarly named set/get functions
  $self->{_ignoreCase_} = 0;
  $self->{_escapeChar_} = '';
  bless ($self, $class);
  return $self;
}

sub ignoreCase {
  my ($self, $value) = @_;
  if (defined($value)) {
    $self->{_ignoreCase_} = $value;
  }
  return $self->{_ignoreCase_};
}

sub escapeChar{
  my ($self, $value) = @_;
  if (defined($value)) {
    $self->{_escapeChar_} = $value;
  }
  return $self->{_escapeChar_};
}

#######################
# Public Parsemaster functions

my $X_DELETE = sub(@$) {
  my $X_offset = pop;
  my @X_match = @_;
  return (chr(001) . $X_match[$X_offset] . chr(001));
}; # NB semicolon required for closure!

# create and add a new pattern to the patterns collection
sub add {
  my ($self, $expression, $X_replacement) = @_;
  if (!$X_replacement) {$X_replacement = $X_DELETE};

  # count the number of sub-expressions
  my $temp = &_X_internalEscape($expression);
  my $length  = 1; # Always at least one because each pattern is itself a sub-expression
     $length += $temp =~ s/$X_GROUPS//g; # One way to count the left capturing parentheses in the regexp string

  # does the pattern deal with sub-expressions?
  if ((ref($X_replacement) ne "CODE") && ($X_replacement =~ m/$X_SUB_REPLACE/)) {
    if ($X_replacement =~ m/$X_INDEXED/) { # a simple lookup? (eg "$2")
      # store the index (used for fast retrieval of matched strings)
      $X_replacement = substr($X_replacement,1) - 1;
    }
    else { # a complicated lookup (eg "Hello $2 $1")
      my $i = $length;
      while ($i) { # Had difficulty getting Perl to do Dean's splitting and joining of strings containing $'s
        my $str = '$a[$o+' . ($i-1) . ']'; # eg $a[$o+1]
        $X_replacement =~ s/\$$i/$str/;      # eg $2 $3 -> $a[$o+1] $a[$o+2]
        $i--;
      }
      # build a function to do the lookup - returns interpolated string of array lookups
      $X_replacement = eval('sub {my $o=pop; my @a=@_; return "' . $X_replacement . '"};');
    }
  }
  else {}
  # pass the modified arguments
  &_X_add($expression || q/^$/, $X_replacement, $length);
}

# execute the global replacement
sub exec {
#print Dumper(@_X_patterns);
  my ($self, $X_string) = @_;
  my $escChar    = $self->escapeChar();
  my $ignoreCase = $self->ignoreCase();
  my ($regexp,$captures) = &_getPatterns();  # Concatenated and parenthesized regexp eg '(regex1)|(regex2)|(regex3)' etc
  $X_string = &_X_escape($X_string, $escChar);
  if ($ignoreCase) {$X_string =~ s/$regexp/{&_X_replacement(&_matchVars($captures,\$X_string))}/gie} # Pass $X_String as a
    else           {$X_string =~ s/$regexp/{&_X_replacement(&_matchVars($captures,\$X_string))}/ge}  # reference for speed

  $X_string = &_X_unescape($X_string, $escChar);
  $X_string =~ s/$XX_DELETED//g;
  return $X_string;
}

sub _X_add {
  push (@_X_patterns, [@_]); # Save each argument set as is into an array of arrays
}

# this is the global replace function (it's quite complicated)
sub _X_replacement {
  my (@arguments) = @_;
#print Dumper (@arguments);
  if ($arguments[0] le '') {return ''}
  # Dereference last index (source String) here - faster than in _matchVars (maybe not needed at all?)
  $arguments[$#arguments] = ${$arguments[$#arguments]};
  my $i = 1;
  # loop through the patterns
  for (my $j=0; $j<scalar(@_X_patterns); $j++) { # Loop through global all @_X_patterns
    my @X_pattern = @{$_X_patterns[$j]};
    # do we have a result? NB: "if ($arguments[$i])" as in Dean's Javascript is false for the value 0!!!
    if ((defined $arguments[$i]) && ($arguments[$i] gt '')) {
      my $X_replacement = $X_pattern[$X_REPLACEMENT];
      # switch on type of $replacement
      if (ref($X_replacement) eq "CODE") {     # function
        return &$X_replacement(@arguments,$i);
      }
      elsif ($X_replacement =~ m/$DIGIT/) {    # number (contains no non-digits)
        return $arguments[$X_replacement + $i];
      }
      else { # default
        return $X_replacement;                 # default
      }
    } # skip over references to sub-expressions
    else {$i += $X_pattern[$X_LENGTH]}
  }
}

#######################
# Private functions
#######################

# encode escaped characters
sub _X_escape {
  my ($X_string, $X_escapeChar) = @_;
  if ($X_escapeChar) {
    my $re = '\\'.$X_escapeChar.'(.)';
    $X_string =~ s/$re/{push(@_X_escaped,$1); $X_escapeChar}/ge;
  }
  return $X_string;
}

# decode escaped characters
sub _X_unescape {
  my ($X_string, $X_escapeChar) = @_;
  if ($X_escapeChar) { # We'll only do this if there is an $X_escapeChar!
    my $re = '\\'.$X_escapeChar;
    $X_string =~ s/$re/{$X_escapeChar . (shift(@_X_escaped))}/ge; # Don't use Dean Edwards as below 'or' here - because zero will return ''!
  # $X_string =~ s/$re/{$X_escapeChar . (shift(@_X_escaped) || '')}/ge;
  }
  return $X_string;
}

sub _X_internalEscape {
  my ($string) = shift;
  $string =~ s/$XX_ESCAPE//g;
  return $string;
}

# Builds an array of match variables to (approximately) emulate that available in Javascript String.replace()
sub _matchVars {
  my ($m,$sref) = @_;
  my @args = (1..$m);                # establish the number potential memory variables
  my @mv = map {eval("\$$_")} @args; # matchvarv[1..m] = the memory variables $1 .. $m
  unshift (@mv, $&);                 # matchvar[0]     = the substring that matched
  push    (@mv, length($`));         # matchvar[m+1]   =  offset within the source string where the match occurred (= length of prematch string)
  push    (@mv, $sref);              # matchvar[m+2]   = reference to full source string (dereference in caller if/when needed)
#print Dumper (@mv);
  return @mv;
}

sub _getPatterns {
  my @Patterns = ();
  my $lcp = 0;
  for (my $i=0; $i<scalar(@_X_patterns); $i++) {       # Loop through global all @_patterns
    push (@Patterns, $_X_patterns[$i][$X_EXPRESSION]); # accumulate the expressions
    $lcp += $_X_patterns[$i][$X_LENGTH];               # sum the left capturing parenthesis counts
  }
  my $str = "(" . join(')|(',@Patterns). ")";          # enclose each pattern in () separated by "|"
  return ($str, $lcp);
}

##################
# END            #
##################
1; # ParseMaster #
##################

[RXL]

Ничего нового в твоей теме нет. Темы объединил.

Вика, прошло 7 месяцев, а воз и ныне там? Перечитай посты данной темы начиная с ответа #15.