вторник, 14 сентября 2021 г.

Об unicode в Perl

В очередной раз задумался о том, какие строки оптимальней использовать в основном коде: characters или octets.

Обычно мне очень редко приходиться работать непосредственно с unicode. Когда нужно, я преобразовываю octets в characters, а затем обратно.

Но HTML::Parser требует на вход unicode, и JSON::XS корректно работает только с unicode. Поэтому хоть непосредственно я сам не использую characters, приходиться перекодировать при помощи модуля Encode.

Кроме этих модулей, обычно все работают с octets.

А вот при работе над магазинчиком вышивки бисером и нитками Embroidery Kits выяснилось, что остальные используемый модули могут работать как с octets, так и с characters (кроме Digest::SHA).

HTML::Parser и JSON::XS перетянули одеяло на себя. Задумался.

P.S.
Utf8 флаг в сложных структурах данных расставляю, сбрасываю при помощи нижеприведенного кода.

use Encode;
use Scalar::Util qw(looks_like_number);


sub data_walk($$);
sub data_walk($$) {
  my ($d,$s) = @_;
  if (ref $d eq "ARRAY") {
    $d = [ map { data_walk($_, $s) } @$d ];
  } elsif (ref $d eq "HASH") {
    $d = { map { $s->($_) => data_walk($$d{$_}, $s) } keys %$d };
  } elsif (not ref $d) {
    $d = $s->($d)
  }
  return $d;
}


sub data_encode_utf8 { data_walk(shift,
    sub {
      my $data = shift;
      if ($data and not looks_like_number($data)) {
        $data = Encode::encode_utf8($data) if Encode::is_utf8($data);
      }
      return $data;
    }
  )
}


sub data_decode_utf8 { data_walk(shift,
    sub {
      my $data = shift;
      if ($data and not looks_like_number($data)) {
        $data = Encode::decode_utf8($data, Encode::FB_QUIET) unless Encode::is_utf8($data);
        $data ||= "ERROR: FOR SOME REASON, TEXT CONVERSION TO UTF8 FAILED";
      }
      return $data;
    }
  )
}

пятница, 31 мая 2019 г.

HTML::Parser vs HTML::TreeBuilder vs HTML::Gumbo

Benchmark для http://perl.org/ страницы.
Извлекаем текс и ссылки.

             Rate       Tree    Gumbo pure    Gumbo   Gumbo cb       SAX
Tree         46/s         --       -63%       -72%       -80%       -87%
Gumbo pure  122/s       167%         --       -24%       -47%       -64%
Gumbo       161/s       252%        32%         --       -30%       -53%
Gumbo cb    230/s       403%        89%        43%         --       -32%
SAX         339/s       642%       178%       111%        47%         --

где:
SAX       - это HTML::Parser
Tree      - HTML::TreeBuilder 
Gumbo     - HTML::Gumbo with tree output format
Gumbo cb  - HTML::Gumbo with callback output format

Обнако обнаружил, что HTML::Gumbo with tree output format на некоторых HTML страничах течет.
https://rt.cpan.org/Public/Bug/Display.html?id=128667

HTML::Gumbo строит DOM при помощи HTML::Elements со стороны XSUB.

Поэтому решил попробовал строить DOM при помощи HTML::Elements с стороны pure perl, а не XSUB.
Это вариант обозначен как "Gumbo pure" в таблице результата Benchmark.

четверг, 26 ноября 2015 г.

Упрощаем работу с многоуровневыми структурами данных из внешних источников

В Perl, благодаря "самооживлению" ссылок, очень удобна работа с многоуровневыми структурами данных. Например:
 my %foo = ();
 
 my $k = "k";
 $foo{$k}{a} = "b";
 $foo{$k}{c} = "d";
Однако, если %foo - это внешняя база данных, например BerkeleyDB, то значения необходимо запаковать тем же Storable или JSON.
При этом удобство работы с многоуровневыми структурами данных снижается.

Необходимо извлечь значение, распаковать его, а если значения не было, то создать. Затем после изменения - запаковать и поместить обратно.
 my %foo = ();

 my $k = "k";

 my $f;
 if (my $_f = $foo{$k}) {
  $f = decode_json $_f;
 } else {
  $f = {};
 }

 $$f{a} = "b";
 $$f{c} = "d";

 $foo{$k} = encode_json $f;
Теперь представим, что это необходимо делать в разных местах программы.
Проще написать функцию для внесения изменений, которая будет вызываться примерно вот как:
 $foo->($k, sub {
  my ($v) = @_;
  $$v{a} = "b";
  $$v{c} = "d";
  return $v;
 } );
Немножко многословно. Но в Perl есть "магическая" переменная $_, которая позволяет сделать следующие:
 $foo->($k, sub {
  $$_{a} = "b";
  $$_{c} = "d";
 } );
Соответственно, сама функция будет выглядеть так:
 my %foo = ();
 
 my $foo = sub {
  my ($k, $sub) = @_;

  local $_;

  if (my $_f = $foo{$k}) {
   $_ = decode_json $_f;
  } else {
   $_ = {};
  }

  $sub->();

  $foo{$k} = encode_json $_;
 };
Хотя можно и так:
 sub foo(&$);

 my %foo = ();

 local *foo = sub {
  my ($sub, $k) = @_;

  local $_;

  if (my $_f = $foo{$k}) {
   $_ = decode_json $_f;
  } else {
   $_ = {};
  }

  $sub->();

  $foo{$k} = encode_json $_;
 };

 foo {
  $$_{a} = "b";
  $$_{c} = "d";
 } "k";
Даже не знаю как лучше... :-)

среда, 24 декабря 2014 г.

HTTP content encoding

Решил прикрутить к AnyEvent::HTTP Accept-Encoding и к LWP в response_data handler, но перед этим выяснить какой процент серверов понимает gzip и deflate.

deflate кодирование реализовано в серверах двумя способами и поэтому авторы nginx отказались от его реализации и используют только gzip
(http://sysoev.ru/mod_deflate/readme.html#mehtods).

Под рукой оказался файл с 53587 доменами со следующим распределением по зонам:
  29244 com    1000 de      627 it
   3102 org     935 info    553 ca
   2786 uk      861 nl      504 si
   2734 net     853 au      467 fr
   1315 ru      682 br      368 ua

Для каждого домена запрашивал HTTP содержимое с указанием "Accept-Encoding" в трех различных вариантах: "gzip, deflate" (приоритет gzip), "deflate, gzip" (приоретет deflate) и "deflate". Результаты как закодировал ответ сервер представлены в нижеприведенной таблице (прочерк означает, что сервер вернул не закодированное содержимое):
             | "gzip, deflate" | "deflate, gzip" | "deflate"
 ------------|-----------------|-----------------|----------
 -           |     22888       |     22764       |  50462
 gzip        |     30612       |     30442       |    145
 deflate     |        67       |       361       |   2959
 iso-8859-1  |         1       |         1       |      1
 none        |        16       |        16       |     16
 none;       |         1       |         1       |      1
 UTF-8       |         2       |         2       |      2

Как видим, можно ограничиться поддержкой лишь одного gzip.

Заодно узнал популярность серверов:
                Все зоны | ru зона | ua зона
 ------------------------|---------|--------
 Apache            27327 |     978 |    443 
 nginx              6924 |     922 |    332
 Microsoft-IIS      6886 |     323 |    148
 -                  6116 |     212 |    103

пятница, 13 июня 2014 г.

COW in perl-5.20

В perl-5.20 реализовали механизм копирования при записи (copy-on-write) для строк. Теперь при присвоении одному скаляру значения другого, копирования буфера строки сразу не происходит. Это значительно повышает производительность и снимает необходимость передачи аргументов функций по ссылке (если они не будут изменяться).

Сравним скорость вызова подпрограмм с различными комбинация передачи параметра и возвращения результата для предыдущей версии perl и для версии с COW:
> perlbrew use perl-5.18.2
> perl ref_and_val.pl
                  Rate val -> val   val -> ref   ref -> val   ref -> ref  
val -> val     68213/s           --         -51%         -51%         -97%
val -> ref    138122/s         102%           --          -1%         -93%
ref -> val    139276/s         104%           1%           --         -93%
ref -> ref   2000000/s        2832%        1348%        1336%           --

> perlbrew use perl-5.20.0
> perl ref_and_val.pl
            (warning: too few iterations for a reliable count)
            (warning: too few iterations for a reliable count)
            (warning: too few iterations for a reliable count)
                  Rate ref -> val   val -> val   ref -> ref   val -> ref  
ref -> val   2083333/s           --         -17%         -21%         -29%
val -> val   2500000/s          20%           --          -5%         -15%
ref -> ref   2631579/s          26%           5%           --         -11%
val -> ref   2941176/s          41%          18%          12%           --
Результаты впечатляют, так как длина тестируемой строки 100000 символов!

А теперь возьмем реальное приложение. Оно сетевое, занимается "перекладыванием байтиков" с одного источника в 4 на основе srs32.
Ниже приведены количество запрос в секунду для 3 различных типов запросов в простом и pipeline режимах. Уточнение: сеть не является узким местом.
                 1     2     3
perl-5.14.4   7272  6134  3886
perl-5.18.2   7610  6439  4139
perl-5.20.0   7581  6459  4338

pipeline mode:
perl-5.14.4  21141 13869  5998
perl-5.18.2  21367 14025  6269
perl-5.20.0  21598 14367  6518
Как видим, в реальном приложении выигрыш от COW не заметен.

понедельник, 12 ноября 2012 г.

Деструкторы для замыканий, часть 2

Первая часть.

А если замыкание используется лишь в самом начале блока, то рациональней сразу после использования освободить ресурсы, а не в конце.

 use Carp;

 sub with_foo {
  my $foo = shift;
  my $sub = shift;
  print "INIT\n";
  my $destroyed = 0;
  my $closure = sub {
   unless ($destroyed) {
    $foo += shift;
    print $foo, "\n";
   } else {
    carp "Already destroyed";
   } 
  };
  my $destructor = sub {
   unless ($destroyed) {
    $destroyed = 1;
    print "DESTROY\n";
   } else {
    carp "Already destroyed";
   }
  };
  eval { $sub->($closure, $destructor) };
  $destructor->() unless $destroyed;
 }
 
 {
  with_foo(3, sub {
   my ($foo, $_foo) = @_;
   $foo->(1);
   $foo->(1);
   $foo->(2);
   $foo->(2);
   $_foo->();
   print "END\n"
  });
 }

четверг, 27 сентября 2012 г.

Very simple Multithreading with Continuation-passing style

{
 my @cc = ();

 sub cc(&) {
  my ($sub) = @_;
  push @cc, $sub;
 }

 sub cc_run() {
  while (my $sub = shift @cc) {
   $sub->();
   sleep 1;
  }
 }
}


sub first {
 my ($thread) = @_;
 print "$thread: 1 first\n";
 cc { third($thread) };
}

sub second {
 my ($thread) = @_;
 print "$thread: 2 second\n";
 cc { fourth($thread) };
}

sub third {
 my ($thread) = @_;
 print "$thread: 3 third\n";
 cc { first($thread) };
}

sub fourth {
 my ($thread) = @_;
 print "$thread: 4 fourth\n\n";
 cc { second($thread) };
}


cc { first("+") };
cc { second("*") };
cc_run;