Форум программистов «Весельчак У»
  *
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
Вам не пришло письмо с кодом активации?

  • Рекомендуем проверить настройки временной зоны в вашем профиле (страница "Внешний вид форума", пункт "Часовой пояс:").
  • У нас больше нет рассылок. Если вам приходят письма от наших бывших рассылок mail.ru и subscribe.ru, то знайте, что это не мы рассылаем.
   Начало  
Наши сайты
Помощь Поиск Календарь Почта Войти Регистрация  
 
Страниц: [1] 2  Все   Вниз
  Печать  
Автор Тема: perl javascript packer  (Прочитано 47008 раз)
0 Пользователей и 2 Гостей смотрят эту тему.
vika
Постоялец

ru
Offline Offline
Пол: Женский

« : 13-02-2012 01:33 » 

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

Offline Offline
Пол: Мужской

WWW
« Ответ #1 : 13-02-2012 03:32 » 

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

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

... мы преодолеваем эту трудность без синтеза распределенных прототипов. (с) Жуков М.С.
vika
Постоялец

ru
Offline Offline
Пол: Женский

« Ответ #2 : 13-02-2012 17:47 » 

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

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


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

Offline Offline
Пол: Мужской

WWW
« Ответ #3 : 13-02-2012 18:47 » 

Одно слово в гугле и пару минут тыкания мышкой. Итог: исходники на 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
Постоялец

ru
Offline Offline
Пол: Женский

« Ответ #4 : 13-02-2012 18:56 » 

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

Offline Offline
Пол: Мужской

WWW
« Ответ #5 : 13-02-2012 19:02 » 

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

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

Добавлено через 20 минут и 27 секунд:
Приведи фрагмент "сжатого" JavaScript.
« Последнее редактирование: 13-02-2012 19:31 от RXL » Записан

... мы преодолеваем эту трудность без синтеза распределенных прототипов. (с) Жуков М.С.
vika
Постоялец

ru
Offline Offline
Пол: Женский

« Ответ #6 : 13-02-2012 19:52 » 

Код:
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
Команда клуба

ua
Offline Offline
Пол: Мужской

WWW
« Ответ #7 : 13-02-2012 20:34 » 

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

Мы все учились понемногу... Чему-нибудь и как-нибудь.
vika
Постоялец

ru
Offline Offline
Пол: Женский

« Ответ #8 : 13-02-2012 20:47 » 

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

Offline Offline
Пол: Мужской

WWW
« Ответ #9 : 13-02-2012 20:57 » 

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

Код: (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).
« Последнее редактирование: 13-02-2012 20:58 от RXL » Записан

... мы преодолеваем эту трудность без синтеза распределенных прототипов. (с) Жуков М.С.
vika
Постоялец

ru
Offline Offline
Пол: Женский

« Ответ #10 : 13-02-2012 20:59 » 

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

Добавлено через 2 минуты и 6 секунд:
Так у самого разработчика этого пакера есть форма, там прямо указано, как преобразуется скрипт http://dean.edwards.name/packer/ (base62 и обрезание)
« Последнее редактирование: 13-02-2012 21:01 от vika » Записан
RXL
Технический
Администратор

Offline Offline
Пол: Мужской

WWW
« Ответ #11 : 13-02-2012 21:04 » 

К примеру,

Код: (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"? Только ответив на него будешь знать, нужно ли оно тебе и как его получить.
« Последнее редактирование: 13-02-2012 21:08 от RXL » Записан

... мы преодолеваем эту трудность без синтеза распределенных прототипов. (с) Жуков М.С.
vika
Постоялец

ru
Offline Offline
Пол: Женский

« Ответ #12 : 13-02-2012 21:13 » 

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

Offline Offline
Пол: Мужской

WWW
« Ответ #13 : 13-02-2012 21:16 » 

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

... мы преодолеваем эту трудность без синтеза распределенных прототипов. (с) Жуков М.С.
vika
Постоялец

ru
Offline Offline
Пол: Женский

« Ответ #14 : 13-02-2012 21:18 » 

vika, "способ кодировки информации" - это также и Морзянка. Может она тебе нужна? Ага
Я намекаю, что на вопрос ты не ответила.
Ну, то что это не морзянка, я думаю и так видно.  А как перефразировать, я не знаю, женский ум тут значительно уступает мужскому, потому и обратилась за помощью к толковым людям.
Записан
RXL
Технический
Администратор

Offline Offline
Пол: Мужской

WWW
« Ответ #15 : 13-02-2012 21:23 » 

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

Код: (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
Команда клуба

ua
Offline Offline
Пол: Мужской

WWW
« Ответ #16 : 13-02-2012 21:24 » 

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

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

Мы все учились понемногу... Чему-нибудь и как-нибудь.
vika
Постоялец

ru
Offline Offline
Пол: Женский

« Ответ #17 : 13-02-2012 21:34 » 

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

Offline Offline
Пол: Мужской

WWW
« Ответ #18 : 13-02-2012 21:46 » 

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

... мы преодолеваем эту трудность без синтеза распределенных прототипов. (с) Жуков М.С.
vika
Постоялец

ru
Offline Offline
Пол: Женский

« Ответ #19 : 13-02-2012 21:52 » 

Вот, что мне выдается
Код:
Panic: Some symbols not resolvable from C:\packer2.perl\perl56.dll
Записан
RXL
Технический
Администратор

Offline Offline
Пол: Мужской

WWW
« Ответ #20 : 13-02-2012 21:58 » 

Оставь 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! Ничего не надо запускать!  Здесь вам не тут!
« Последнее редактирование: 13-02-2012 22:05 от RXL » Записан

... мы преодолеваем эту трудность без синтеза распределенных прототипов. (с) Жуков М.С.
vika
Постоялец

ru
Offline Offline
Пол: Женский

« Ответ #21 : 13-02-2012 22:09 » 

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

Offline Offline
Пол: Мужской

WWW
« Ответ #22 : 13-02-2012 22:29 » 

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

... мы преодолеваем эту трудность без синтеза распределенных прототипов. (с) Жуков М.С.
vika
Постоялец

ru
Offline Offline
Пол: Женский

« Ответ #23 : 13-02-2012 22:33 » 

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

Offline Offline
Пол: Мужской

WWW
« Ответ #24 : 14-02-2012 05:39 » 

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

... мы преодолеваем эту трудность без синтеза распределенных прототипов. (с) Жуков М.С.
vika
Постоялец

ru
Offline Offline
Пол: Женский

« Ответ #25 : 14-02-2012 17:49 » 

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

Offline Offline
Пол: Мужской

WWW
« Ответ #26 : 14-02-2012 18:34 » 

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

... мы преодолеваем эту трудность без синтеза распределенных прототипов. (с) Жуков М.С.
vika
Постоялец

ru
Offline Offline
Пол: Женский

« Ответ #27 : 14-02-2012 20:42 » 

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

ru
Offline Offline
Пол: Женский

« Ответ #28 : 13-09-2012 01:13 » 

Собственно, уже тему создавала похожу, но теперь приперло. Приветствую всех. Есть пакер на яваскрипт, вот он 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 #
##################
« Последнее редактирование: 13-09-2012 03:48 от RXL » Записан
RXL
Технический
Администратор

Offline Offline
Пол: Мужской

WWW
« Ответ #29 : 13-09-2012 03:53 » 

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

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

... мы преодолеваем эту трудность без синтеза распределенных прототипов. (с) Жуков М.С.
Страниц: [1] 2  Все   Вверх
  Печать  
 

Powered by SMF 1.1.21 | SMF © 2015, Simple Machines