perl

 view release on metacpan or  search on metacpan

Porting/corelist-perldelta.pl  view on Meta::CPAN

}

{
  package DeltaParser;
  use Pod::Simple::SimpleTree;

  sub new {
    my ($class, $input) = @_;

    my $self = bless {} => $class;

    my $parsed_pod = Pod::Simple::SimpleTree->new->parse_file($input)->root;
    splice @{ $parsed_pod }, 0, 2; # we don't care about the document structure,
                                   # just the nodes within it

    $self->_parse_delta($parsed_pod);

    return $self;
  }

cpan/CPAN-Meta-Requirements/lib/CPAN/Meta/Requirements.pm  view on Meta::CPAN

my @valid_options = qw( bad_version_hook );

sub new {
  my ($class, $options) = @_;
  $options ||= {};
  Carp::croak "Argument to $class\->new() must be a hash reference"
    unless ref $options eq 'HASH';
  my %self = map {; $_ => $options->{$_}} @valid_options;

  return bless \%self => $class;
}

#pod =method add_minimum
#pod
#pod   $req->add_minimum( $module => $version );
#pod
#pod This adds a new minimum version requirement.  If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Minimum requirements are inclusive.  C<$version> is required, along with any

cpan/CPAN-Meta/lib/CPAN/Meta/Feature.pm  view on Meta::CPAN

sub new {
  my ($class, $identifier, $spec) = @_;

  my %guts = (
    identifier  => $identifier,
    description => $spec->{description},
    prereqs     => CPAN::Meta::Prereqs->new($spec->{prereqs}),
  );

  bless \%guts => $class;
}

#pod =method identifier
#pod
#pod This method returns the feature's identifier.
#pod
#pod =cut

sub identifier  { $_[0]{identifier}  }

cpan/CPAN-Meta/lib/CPAN/Meta/Prereqs.pm  view on Meta::CPAN

      my $spec = $phase_spec->{ $type };

      next TYPE unless keys %$spec;

      $guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash(
        $spec
      );
    }
  }

  return bless \%guts => $class;
}

#pod =method requirements_for
#pod
#pod   my $requirements = $prereqs->requirements_for( $phase, $type );
#pod
#pod This method returns a L<CPAN::Meta::Requirements> object for the given
#pod phase/type combination.  If no prerequisites are registered for that
#pod combination, a new CPAN::Meta::Requirements object will be returned, and it may
#pod be added to as needed.

cpan/Encode/lib/Encode/Encoder.pm  view on Meta::CPAN

    }
    else {
        my $obj = find_encoding($encname)
          or croak __PACKAGE__, ": unknown encoding: $encname";
        $encname = $obj->name;
    }
    my $self = {
        data     => $data,
        encoding => $encname,
    };
    bless $self => $class;
}

sub encoder { __PACKAGE__->new(@_) }

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

cpan/Encode/t/Encode.t  view on Meta::CPAN

ok(  is_utf8($1)); # ID 20011127.151
$a = $1;
ok(  is_utf8($a));
$a = "\x{100}";
chop $a;
ok(  is_utf8($a)); # weird but true: an empty UTF-8 string

# non-string arguments
package Encode::Dummy;
use overload q("") => sub { $_[0]->[0] };
sub new { my $class = shift; bless [ @_  ] => $class }
package main;
ok(decode(latin1 => Encode::Dummy->new("foobar")), "foobar");
ok(encode(utf8   => Encode::Dummy->new("foobar")), "foobar");

# RT#91569
# decode_utf8 with non-string arguments
ok(decode_utf8(*1), "*main::1");

# hash keys
foreach my $name ("UTF-16LE", "UTF-8", "Latin1") {

cpan/HTTP-Tiny/t/BrokenCookieJar.pm  view on Meta::CPAN

package BrokenCookieJar;

use strict;
use warnings;

sub new {
    my $class = shift;
    return bless {} => $class;
}

package BrokenCookieJar2;

use strict;
use warnings;

sub new {
    my $class = shift;
    return bless {} => $class;
}

sub add {
}

1;

cpan/HTTP-Tiny/t/SimpleCookieJar.pm  view on Meta::CPAN

package SimpleCookieJar;

use strict;
use warnings;

sub new {
    my $class = shift;
    return bless {} => $class;
}

sub add {
    my ($self, $url, $cookie) = @_;
    
    my ($kv) = split qr/;/, $cookie;
    my ($k, $v) = split qr/\s*=\s*/, $kv, 2;

    $self->{$url}{$k} = $v;
}

cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm  view on Meta::CPAN

sub ckMagic
{
    my $self = shift;
    my @names = @_ ;

    my $keep = ref $self ;
    for my $class ( map { "IO::Uncompress::$_" } @names)
    {
        bless $self => $class;
        my $magic = $self->ckMagic();

        if ($magic)
        {
            #bless $self => $class;
            return $magic ;
        }

        $self->pushBack(*$self->{HeaderPending})  ;
        *$self->{HeaderPending} = ''  ;
    }

    bless $self => $keep;
    return undef;
}

cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm  view on Meta::CPAN

sub ckMagic
{
    my $self = shift;
    my @names = @_ ;

    my $keep = ref $self ;
    for my $class ( map { "IO::Uncompress::$_" } @names)
    {
        bless $self => $class;
        my $magic = $self->ckMagic();

        if ($magic)
        {
            #bless $self => $class;
            return $magic ;
        }

        $self->pushBack(*$self->{HeaderPending})  ;
        *$self->{HeaderPending} = ''  ;
    }

    bless $self => $keep;
    return undef;
}

cpan/Test-Harness/lib/App/Prove/State/Result.pm  view on Meta::CPAN

Returns a new C<App::Prove::State::Result> instance.

=cut

sub new {
    my ( $class, $arg_for ) = @_;
    $arg_for ||= {};
    my %instance_data = %$arg_for;    # shallow copy
    $instance_data{version} = $class->state_version;
    my $tests = delete $instance_data{tests} || {};
    my $self = bless \%instance_data => $class;
    $self->_initialize($tests);
    return $self;
}

sub _initialize {
    my ( $self, $tests ) = @_;
    my %tests;
    while ( my ( $name, $test ) = each %$tests ) {
        $tests{$name} = $self->test_class->new(
            {   %$test,

cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm  view on Meta::CPAN

=head2 Class Methods

=head3 C<new>

=cut

sub new {
    my ( $class, $arg_for ) = @_;
    $arg_for ||= {};
    bless $arg_for => $class;
}

=head2 Instance Methods

=head3 C<name>

The name of the test.  Usually a filename.

=head3 C<elapsed>

dist/Unicode-Normalize/t/tie.t  view on Meta::CPAN

use warnings;
BEGIN { $| = 1; print "1..17\n"; }
my $count = 0;
sub ok { Unicode::Normalize::ok(\$count, @_) }

ok(1);

package tiescalar;
sub TIESCALAR {
    my ($class, $instance) = @_;
    return bless \$instance => $class;
}
sub FETCH   { return ${$_[0]}++ }
sub STORE   { return ${$_[0]} = $_[1] }
sub DESTROY { undef ${$_[0]} }

#########################

package main;

tie my $tie1, 'tiescalar', "123";

ext/IPC-Open3/t/IPC-Open3.t  view on Meta::CPAN

like($@, qr/^open3: Modification of a read-only value attempted at /,
     'open3 faults read-only parameters correctly') or do {waitpid $pid, 0};

package NoFetch;

my $fetchcount = 1;

sub TIESCALAR {
  my $class = shift;
  my $instance = shift || undef;
  return bless \$instance => $class;
}

sub FETCH {
    my $cmd; #dont let "@args = @DB::args;" in Carp::caller_info fire this die
    #fetchcount may need to be increased to 2 if this code is being stepped with
    #a perl debugger
    if($fetchcount == 1 && (caller(1))[3] ne 'Carp::caller_info') {
	#Carp croak reports the errors as being in IPC-Open3.t, so it is
	#unacceptable for testing where the FETCH failure occured, we dont want
	#it failing in a $foo = $_[0]; #later# system($foo), where the failure

lib/Tie/Scalar.pm  view on Meta::CPAN

# The Tie::StdScalar package provides scalars that behave exactly like
# Perl's built-in scalars. Good base to inherit from, if you're only going to
# tweak a small bit.
#
package Tie::StdScalar;
@ISA = qw(Tie::Scalar);

sub TIESCALAR {
    my $class = shift;
    my $instance = @_ ? shift : undef;
    return bless \$instance => $class;
}

sub FETCH {
    return ${$_[0]};
}

sub STORE {
    ${$_[0]} = $_[1];
}

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

    bless \$victim;
    is $w, undef,
       'no warnings when reblessing inside DESTROY triggered by reblessing'
}

TODO: {
    my $ref;
    sub new {
        my ($class, $code) = @_;
        my $ret = ref($code);
        bless $code => $class;
        return $ret;
    }
    for my $i (1 .. 2) {
        $ref = main -> new (sub {$i});
    }
    is $ref, 'CODE', 'RT #3305: Code ref should not be blessed yet';

    local $TODO = 'RT #3305';

    for my $i (1 .. 2) {

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

    }
    is $ref, 'CODE', 'RT #3305: Code ref should not be blessed yet';
}

my $t_3306_c = 0;
my $t_3306_s = 0;

{
    sub FooClosure::new {
        my ($class, $code) = @_;
        bless $code => $class;
    }
    sub FooClosure::DESTROY {
        $t_3306_c++;
    }

    sub FooSub::new {
        my ($class, $code) = @_;
        bless $code => $class;
    }
    sub FooSub::DESTROY {
        $t_3306_s++;
    }

    my $i = '';
    FooClosure -> new (sub {$i});
    FooSub -> new (sub {});
}

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

    require './test.pl';
    set_up_inc('../lib');
}


package Countdown;

sub TIESCALAR {
  my $class = shift;
  my $instance = shift || undef;
  return bless \$instance => $class;
}

sub FETCH {
  print "# FETCH!  ${$_[0]}\n";
  return ${$_[0]}--;
}


package main;

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

{
    # Bug ID 20010730.010 (#7387)

    my $i = 0;

    sub Tie::TIESCALAR {
        my $class =  shift;
        my $arg   =  shift;

        bless \$arg => $class;
    }

    sub Tie::FETCH {
        $i ++;
        ${$_ [0]}
    }

 
    package main;