view release on metacpan or  search on metacpan

tests/228_hooks.t  view on Meta::CPAN

with_hooks();

$c->tag($_, Hooks => undef) for qw(Enum String);

{
  my $hook = $reason
           ? sub { $_[0] }  # identity
           : sub { Scalar::Util::dualvar($_[0], $TEXTID{$_[0]}) };

  $c->tag('TextId', Hooks => { unpack => $hook, pack => undef });
}

with_single_hook();
$c = $c->clone;
with_single_hook();

# This should completely remove the 'TextId' hooks
$c->tag('TextId', Hooks => { unpack => undef });

no_hooks();
$c = $c->clone;
no_hooks();

$c->tag('Enum',   Hooks => undef)
  ->tag('TextId', Hooks => undef)
  ->tag('String', Hooks => undef)
  ->tag('Enum',   Hooks => { pack   => \&enum_pack     })
  ->tag('TextId', Hooks => { pack   => \&textid_pack   })
  ->tag('String', Hooks => { pack   => \&string_pack   })
  ->tag('Enum',   Hooks => { unpack => \&enum_unpack   })
  ->tag('TextId', Hooks => { unpack => \&textid_unpack })
  ->tag('String', Hooks => { unpack => \&string_unpack });

with_hooks();

$c = $c->tag('String', Hooks => undef)
       ->tag('Enum', Hooks => undef)
       ->tag('TextId', Hooks => undef)
       ->clone;

no_hooks();

test_args();

test_ptr_hooks();

sub test_ptr_hooks {
  my $pack = sub { $_[0] =~ /{(0x[^}]+)}/ ? hex $1 : '' };

  $c->tag('Test',   Hooks => { unpack_ptr => sub { sprintf "Test{0x%X}", $_[0] },
                               pack_ptr   => [$pack, $c->arg('DATA')] });
  $c->tag('Date',   Hooks => { unpack_ptr => [sub { sprintf "$_[1]\{0x%X}", $_[0] }, $c->arg('DATA', 'TYPE')],
                               pack_ptr   => $pack });
  $c->tag('Enum',   Hooks => { unpack_ptr => [sub { sprintf "$_[0]\{0x%X}", $_[1] }, $c->arg('TYPE', 'DATA')],
                               pack_ptr   => [$pack, $c->arg('DATA', 'SELF'), 'foo'] });
  $c->tag('TextId', Hooks => { unpack_ptr => [sub { sprintf "Text\{0x%X}", $_[0] }, $c->arg('DATA')],
                               pack_ptr   => $pack });

  my $str = pack('N*', 0xdeadbeef, 0x2badc0de, 0x12345678, 0xdeadc0de);

  my $u = $c->unpack('PtrHookTest', $str);

  ok($u->{pTest}, "Test{0xDEADBEEF}");
  ok($u->{pDate}, "struct Date{0x2BADC0DE}");
  ok($u->{pEnum}, "enum Enum{0x12345678}");
  ok($u->{pText}, "Text{0xDEADC0DE}");

  my $p = $c->pack('PtrHookTest', $u);

  ok($p, $str);

  $c->tag($_, Hooks => undef) for qw( Test Date Enum TextId );
}

sub test_args {
  my(@ap, @au, $x);

  my $sub_p = sub { push @ap, @_; shift };
  my $sub_u = sub { push @au, @_; shift };

  my @t = (
    { type => 'TextId', in_p => 4711, in_u => pack("N", 0x12345678),
      arg_u => [],  res_u => [],
      arg_p => [],  res_p => []  },

    { type => 'TextId', in_p => 4711, in_u => pack("N", 0x12345678),
      arg_u => [1], res_u => [1],
      arg_p => [2], res_p => [2] },

    { type => 'TextId', in_p => 4711, in_u => pack("N", 0x12345678),
      arg_u => [$c->arg('DATA')], res_u => [0x12345678],
      arg_p => [$c->arg('DATA', 'HOOK')], res_p => [4711, 'pack'] },

    { type => 'TextId', in_p => 4711, in_u => pack("N", 0x12345678),
      arg_u => [$c->arg('DATA', 'TYPE', 'SELF'), 123], res_u => [0x12345678, 'TextId', '{self}', 123],
      arg_p => [$c->arg('DATA', 'TYPE', 'SELF'), 456], res_p => [4711, 'TextId', '{self}', 456] },

    { type => 'TextId', in_p => 4711, in_u => pack("N", 0x12345678),
      arg_u => [$c->arg('DATA', 'TYPE'), 'foo', $c->arg('SELF', 'DATA')],
      res_u => [0x12345678, 'TextId', 'foo', '{self}', 0x12345678],
      arg_p => [$c->arg('DATA', 'TYPE'), 'bar', $c->arg('SELF')], res_p => [4711, 'TextId', 'bar', '{self}'] },

    { type => 'Enum', in_p => 'Seven', in_u => pack("N", 8),
      arg_u => [$c->arg('DATA', 'TYPE', 'HOOK')], res_u => ['<ENUM:8>', 'enum Enum', 'unpack'],
      arg_p => [$c->arg('DATA', 'TYPE', 'DATA')], res_p => ['Seven', 'enum Enum', 'Seven'] },

    { type => 'Date', in_p => {}, in_u => pack("N3", 4, 5, 6),
      arg_u => [$c->arg('DATA', 'TYPE')], res_u => [qr/HASH/, 'struct Date'],
      arg_p => [$c->arg('DATA', 'TYPE')], res_p => [qr/HASH/, 'struct Date'] },
  );

  for my $t (@t) {
    $c->tag($t->{type}, Hooks => {
                          pack   => [$sub_p, @{$t->{arg_p}}],
                          unpack => [$sub_u, @{$t->{arg_u}}],
                        });

    for my $cbc ($c, $c->clone) {

      $x = $cbc->pack($t->{type}, $t->{in_p});
      $x = $cbc->unpack($t->{type}, $t->{in_u});