view release on metacpan or  search on metacpan

t/op/attrs.t  view on Meta::CPAN

  sub MODIFY_CODE_ATTRIBUTES { push @proto, $_[1], \&{$_[1]}; _: }
  my $id;
  () = sub :buck {$id};
  &::is(@proto, 'referencing closure prototype');
}

# [perl #68658] Attributes on stately variables
{
  package thwext;
  sub MODIFY_SCALAR_ATTRIBUTES { () }
  my $i = 0;
  my $x_values = '';
  eval 'sub foo { use 5.01; state $x :A0 = $i++; $x_values .= $x }';
  foo(); foo();
  package main;
  is $x_values, '00', 'state with attributes';
}

{
  package ningnangnong;
  sub MODIFY_SCALAR_ATTRIBUTES{}
  sub MODIFY_ARRAY_ATTRIBUTES{  }
  sub MODIFY_HASH_ATTRIBUTES{    }
  my ($cows, @go, %bong) : teapots = qw[ jibber jabber joo ];
  ::is $cows, 'jibber', 'list assignment to scalar with attrs';
  ::is "@go", 'jabber joo', 'list assignment to array with attrs';
}

{
  my $w;
  local $SIG{__WARN__} = sub { $w = shift };
  sub  ent         {}
  sub lent :lvalue {}
  my $posmsg =
      'lvalue attribute applied to already-defined subroutine at '
     .'\(eval';
  my $negmsg =
      'lvalue attribute removed from already-defined subroutine at '
     .'\(eval';
  eval 'use attributes __PACKAGE__, \&ent, "lvalue"';
  like $w, qr/^$posmsg/, 'lvalue attr warning on def sub';
  is join("",&attributes::get(\&ent)), "lvalue",':lvalue applied anyway';
  $w = '';
  eval 'use attributes __PACKAGE__, \&lent, "lvalue"; 1' or die;
  is $w, "", 'no lvalue warning on def lvalue sub';
  eval 'use attributes __PACKAGE__, \&lent, "-lvalue"';
  like $w, qr/^$negmsg/, '-lvalue attr warning on def sub';
  is join("",&attributes::get(\&lent)), "",
       'lvalue attribute removed anyway';
  $w = '';
  eval 'use attributes __PACKAGE__, \&lent, "-lvalue"; 1' or die;
  is $w, "", 'no -lvalue warning on def non-lvalue sub';
  no warnings 'misc';
  eval 'use attributes __PACKAGE__, \&lent, "lvalue"';
  is $w, "", 'no lvalue warnings under no warnings misc';
  eval 'use attributes __PACKAGE__, \&ent, "-lvalue"';
  is $w, "", 'no -lvalue warnings under no warnings misc';
}

unlike runperl(
         prog => 'BEGIN {$^H{a}=b} sub foo:bar{1}',
         stderr => 1,
       ),
       qr/Unbalanced/,
      'attribute errors do not cause op trees to leak';

package ProtoTest {
    sub MODIFY_CODE_ATTRIBUTES { $Proto = prototype $_[1]; () }
    sub foo ($) : gelastic {}
}
is $ProtoTest::Proto, '$', 'prototypes are visible in attr handlers';

{
    my $w;
    local $SIG{__WARN__} = sub { $w = shift };
    attributes ->import(__PACKAGE__, \&foo, "const");
    like $w, qr/^Useless use of attribute "const" at /,
            'Warning for useless const via attributes.pm';
    $w = '';
    attributes ->import(__PACKAGE__, \&foo, "const");
    is $w, '', 'no warning for const if already applied';
    attributes ->import(__PACKAGE__, \&foo, "-const");
    is $w, '', 'no warning for -const with attr already applied';
    attributes ->import(__PACKAGE__, \&bar, "-const");
    is $w, '', 'no warning for -const with attr not already applied';
    package ConstTest;
    sub MODIFY_CODE_ATTRIBUTES {
        attributes->import(shift, shift, lc shift) if $_[2]; ()
    }
    $_ = 32487;
    my $sub = eval '+sub : Const { $_ }';
    ::is $w, '',
     'no warning for :const applied to closure protosub via attributes.pm';
    undef $_;
    ::is &$sub, 32487,
        'applying const attr via attributes.pm';
}

# [perl #123817] Attributes in list-type operators
# These tests used to fail an assertion because the list op generated by
# the lexical attribute declaration was converted to another op type with
# the OPpLVAL_INTRO flag still set.  These op types were not expecting that
# flag to be set, though it was harmless for non-debugging builds.
package _123817 {
    sub MODIFY_SCALAR_ATTRIBUTES {()}
    eval '{my $x : m}';
    eval '[(my $x : m)]';
    eval 'formline my $x : m';
    eval 'return my $x : m';
}

# [perl #126257]
# attributed lex var as function arg caused assertion failure

package P126257 {
    sub MODIFY_SCALAR_ATTRIBUTES {}
    sub MODIFY_ARRAY_ATTRIBUTES  {}
    sub MODIFY_HASH_ATTRIBUTES   {}
    sub MODIFY_CODE_ATTRIBUTES   {}
    sub foo {}
    eval { foo(my $x : bar); };