?????????? ?????????

?????????? ????????? - ??????????????? - /home/agenciai/public_html/cd38d8/t.tar

???????
render_xml.t��0000644��00000001377�15125143113�0007074 0��ustar�00��use lib 'inc'; { use Test::More; eval "use XML::Simple; 1" or plan skip_all => 'XML::Simple required'; } use TestML; TestML->new( testml => do { local $/; <DATA> }, bridge => 'main', )->run; { package main; use base 'TestML::Bridge'; use TestML::Util; use Template::Toolkit::Simple; sub render_template { my ($self, $context) = @_; my $t = -d 't' ? 't' : 'test'; return str tt ->post_chomp ->path("$t/template") ->data("$t/render.xml") ->render($context->value); } } __DATA__ %TestML 0.1.0 Plan = 1; template.render_template == result; === Simple Render --- template: letter.tt --- result Hi Löver, Have a nice day. Smööches, Ingy ��render.yaml��0000644��00000000015�15125143113�0006677 0��ustar�00��name: Löver ��render.json��0000644��00000000030�15125143113�0006703 0��ustar�00��{ "name" : "Löver" } ��release-pod-syntax.t��0000644��00000000456�15125143113�0010456 0��ustar�00��#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use Test::More; use Test::Pod 1.41; all_pod_files_ok(); ��000-compile-modules.t��0000644��00000000362�15125143113�0010321 0��ustar�00��# This test does a basic `use` check on all the code. use Test::More; use File::Find; sub test { s{^lib/(.)\.pm$}{$1} or return; s{/}{::}g; use_ok $_; } find { wanted => \&test, no_chdir => 1, }, 'lib'; done_testing; ��template/signature.tt��0000644��00000000021�15125143113�0010716 0��ustar�00��Smööches, Ingy ��template/letter.tt��0000644��00000000075�15125143113�0010225 0��ustar�00��Hi [% name %], Have a nice day. [% PROCESS signature.tt %] ��render_json.t��0000644��00000001372�15125143113�0007240 0��ustar�00��use lib 'inc'; { use Test::More; eval "use JSON::XS; 1" or plan skip_all => 'JSON::XS required'; } use TestML; TestML->new( testml => do { local $/; <DATA> }, bridge => 'main', )->run; { package main; use base 'TestML::Bridge'; use TestML::Util; use Template::Toolkit::Simple; sub render_template { my ($self, $context) = @_; my $t = -d 't' ? 't' : 'test'; return str tt ->post_chomp ->path("$t/template") ->data("$t/render.json") ->render($context->value); } } __DATA__ %TestML 0.1.0 Plan = 1; template.render_template == result; === Simple Render --- template: letter.tt --- result Hi Löver, Have a nice day. Smööches, Ingy ��render_yaml.t��0000644��00000001225�15125143113�0007226 0��ustar�00��use lib 'inc'; use TestML; TestML->new( testml => do { local $/; <DATA> }, bridge => 'main', )->run; { package main; use base 'TestML::Bridge'; use TestML::Util; use Template::Toolkit::Simple; sub render_template { my ($self, $context) = @_; my $t = -d 't' ? 't' : 'test'; return str tt ->post_chomp ->path("$t/template") ->data("$t/render.yaml") ->render($context->value); } } __DATA__ %TestML 0.1.0 Plan = 1; template.render_template == result; === Simple Render --- template: letter.tt --- result Hi Löver, Have a nice day. Smööches, Ingy ��render.xml��0000644��00000000043�15125143113�0006536 0��ustar�00��<xml> <name>Löver</name> </xml> ��cli.t��0000644��00000002040�15125143113�0005470 0��ustar�00��use lib 'inc'; use TestML; TestML->new( testml => do { local $/; <DATA> }, bridge => 'main', )->run; { package main; use base 'TestML::Bridge'; use TestML::Util; sub run_command { my ($self, $command) = @_; $command = $command->value; if (-d 'test') { $command =~ s/\bt\b/test/g; } open my $execution, "$^X bin/$command \|" or die "Couldn't open subprocess: $!\n"; local $/; my $output = <$execution>; close $execution; return str $output; } sub expected { return str <<'...'; Hi Löver, Have a nice day. Smööches, Ingy ... } } __DATA__ %TestML 0.1.0 Plan = 3; command.Chomp.run_command == expected(); === Render --- command tt-render --post-chomp --data=t/render.yaml --path=t/template/ letter.tt === Render with path//template --- command tt-render --post-chomp --data=t/render.yaml t/template//letter.tt === Options abbreviated --- command tt-render --post-c --d=t/render.yaml -I t/template/ letter.tt ��01-base32hex.t��0000644��00000003204�15125143205�0006730 0��ustar�00��use strict; use warnings; use Test::More; BEGIN { use_ok( 'MIME::Base32' ) \|\| BAIL_OUT("Can't use MIME::Base32"); } can_ok('MIME::Base32', ( qw(encode_base32hex decode_base32hex), qw(encode_09AV decode_09AV), )) or BAIL_OUT("Something's wrong with the module!"); my $string = 'Hallo world, whats new? 1234567890 abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ .:!%$@#()[]{}<>"/ '; my $encoded_hex = '91GMOR3F41RMUSJCCGM20TR8C5Q7683ECLRJU81H68PJ8D9M6SS3IC10C5H66P35CPJMGQBADDM6QRJFE1ON4SRKELR7EU3PF8G42GI38H2KCHQ89554MJ2D9P7L0KAIADA5ALINB1CLK81E78GIA9204CL2GAARBLTNQF1U48NI0'; is(MIME::Base32::encode_base32hex($string),$encoded_hex, 'encode_base32hex: Got the right response'); is(MIME::Base32::decode_base32hex($encoded_hex),$string, 'decode_base32hex: Got the right response'); is(MIME::Base32::decode_base32hex(lc($encoded_hex)),$string, 'decode_base32hex: case insensitive'); is(MIME::Base32::encode_09AV($string),$encoded_hex, 'encode_09AV: Got the right response'); is(MIME::Base32::decode_09AV($encoded_hex),$string, 'decode_09AV: Got the right response'); is(MIME::Base32::decode_09AV(lc($encoded_hex)),$string, 'decode_09AV: case insensitive'); is(MIME::Base32::encode_base32hex(undef), '', 'encode_base32hex: undef passed'); is(MIME::Base32::decode_base32hex(undef), '', 'decode_base32hex: undef passed'); is(MIME::Base32::encode_base32hex(), '', 'encode_base32hex: empty call'); is(MIME::Base32::decode_base32hex(), '', 'decode_base32hex: empty call'); is(MIME::Base32::encode_base32hex(''), '', 'encode_base32hex: empty string passed'); is(MIME::Base32::decode_base32hex(''), '', 'decode_base32hex: empty string passed'); done_testing(); ��00-base32.t��0000644��00000003356�15125143205�0006232 0��ustar�00��use strict; use warnings; use Test::More; BEGIN { use_ok( 'MIME::Base32' ) \|\| BAIL_OUT("Can't use MIME::Base32"); } can_ok('MIME::Base32', ( qw(encode decode), qw(encode_base32 decode_base32), qw(encode_rfc3548 decode_rfc3548), )) or BAIL_OUT("Something's wrong with the module!"); my $string = 'Hallo world, whats new? 1234567890 abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ .:!%$@#()[]{}<>"/ '; my $encoded = 'JBQWY3DPEB3W64TMMQWCA53IMF2HGIDOMV3T6IBRGIZTINJWG44DSMBAMFRGGZDFMZTWQ2LKNNWG23TPOBYXE43UOV3HO6DZPIQECQSDIRCUMR2IJFFEWTCNJZHVAUKSKNKFKVSXLBMVUIBOHIQSKJCAEMVCQKK3LV5X2PB6EIXSA'; is(MIME::Base32::encode($string),$encoded, 'encode: got the correct response'); is(MIME::Base32::decode($encoded),$string, 'decode: got the correct response'); is(MIME::Base32::decode(lc($encoded)),$string, 'decode: case insensitive'); is(MIME::Base32::encode_base32($string),$encoded, 'encode_base32: got the correct response'); is(MIME::Base32::decode_base32($encoded),$string, 'decode_base32: got the correct response'); is(MIME::Base32::decode_base32(lc($encoded)),$string, 'decode_base32: case insensitive?'); is(MIME::Base32::encode_rfc3548($string),$encoded, 'encode_rfc3548: got the correct response'); is(MIME::Base32::decode_rfc3548($encoded),$string, 'decode_rfc3548: got the correct response'); is(MIME::Base32::decode_rfc3548(lc($encoded)),$string, 'decode_rfc3548: case insensitive'); is(encode_base32(undef),'','encode_base32: undef passed'); is(decode_base32(undef),'','decode_base32: undef passed'); is(encode_base32(),'','encode_base32: empty call'); is(decode_base32(),'','decode_base32: empty call'); is(encode_base32(''),'','encode_base32: empty string passed'); is(decode_base32(''),'','decode_base32: empty string passed'); done_testing(); ��chmod.t��0000644��00000001774�15125143206�0006033 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use TestUtils qw/exception/; use Path::Tiny; my $fh = path("t/data/chmod.txt")->openr; while ( my $line = <$fh> ) { chomp $line; my ( $chmod, $orig, $expect ) = split " ", $line; my $got = sprintf( "%05o", Path::Tiny::_symbolic_chmod( oct($orig), $chmod ) ); is( $got, $expect, "$orig -> $chmod -> $got" ); } my $path = Path::Tiny->tempfile; like( exception { $path->chmod("ldkakdfa") }, qr/Invalid mode argument/, "Invalid mode throws exception" ); like( exception { $path->chmod("sdfa=kdajfkl") }, qr/Invalid mode clause/, "Invalid mode clause throws exception" ); ok( exception { path("adljfasldfj")->chmod(0700) }, "Nonexistent file throws exception" ); done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # vim: ts=4 sts=4 sw=4 et: ��symlinks.t��0000644��00000003016�15125143206�0006601 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use TestUtils qw/exception has_symlinks/; use Path::Tiny; use Cwd 'abs_path'; plan skip_all => "No symlink support" unless has_symlinks(); subtest "relative symlinks with updir" => sub { my $temp = Path::Tiny->tempdir; my $td = $temp->realpath; $td->child(qw/tmp tmp2/)->mkdir; my $foo = $td->child(qw/tmp foo/)->touch; my $bar = $td->child(qw/tmp tmp2 bar/); symlink "../foo", $bar or die "Failed to symlink: $!\n"; ok -f $foo, "it's a file"; ok -l $bar, "it's a link"; is readlink $bar, "../foo", "the link seems right"; is abs_path($bar), $foo, "abs_path gets's it right"; is $bar->realpath, $foo, "realpath get's it right"; }; subtest "symlink loop detection" => sub { my $temp = Path::Tiny->tempdir; my $td = $temp->realpath; $td->child("A")->touch; for my $pair ( [qw/A B/], [qw/B C/], [qw/C A/] ) { my $target = $td->child( $pair->[1] ); $target->remove if -e $target; symlink $pair->[0], $td->child( $pair->[1] ) or die "Failed to symlink @$pair: $!\n"; } diag for $td->children; like( exception { $td->child("A")->realpath }, qr/symlink loop detected/, "symlink loop detected" ); }; done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # vim: set ts=4 sts=4 sw=4 et tw=75: ��recurse.t��0000644��00000017655�15125143206�0006416 0��ustar�00��#!./perl # # Copyright (c) 1995-2000, Raphael Manfredi # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # use Config; sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use Storable qw(freeze thaw dclone); $Storable::flags = Storable::FLAGS_COMPAT; use Test::More tests => 39; package OBJ_REAL; use Storable qw(freeze thaw); @x = ('a', 1); sub make { bless [], shift } sub STORABLE_freeze { my $self = shift; my $cloning = shift; die "STORABLE_freeze" unless Storable::is_storing; return (freeze(\@x), $self); } sub STORABLE_thaw { my $self = shift; my $cloning = shift; my ($x, $obj) = @_; die "STORABLE_thaw #1" unless $obj eq $self; my $len = length $x; my $a = thaw $x; die "STORABLE_thaw #2" unless ref $a eq 'ARRAY'; die "STORABLE_thaw #3" unless @$a == 2 && $a->[0] eq 'a' && $a->[1] == 1; @$self = @$a; die "STORABLE_thaw #4" unless Storable::is_retrieving; } package OBJ_SYNC; @x = ('a', 1); sub make { bless {}, shift } sub STORABLE_freeze { my $self = shift; my ($cloning) = @_; return if $cloning; return ("", \@x, $self); } sub STORABLE_thaw { my $self = shift; my ($cloning, $undef, $a, $obj) = @_; die "STORABLE_thaw #1" unless $obj eq $self; die "STORABLE_thaw #2" unless ref $a eq 'ARRAY' \|\| @$a != 2; $self->{ok} = $self; } package OBJ_SYNC2; use Storable qw(dclone); sub make { my $self = bless {}, shift; my ($ext) = @_; $self->{sync} = OBJ_SYNC->make; $self->{ext} = $ext; return $self; } sub STORABLE_freeze { my $self = shift; my %copy = %$self; my $r = \%copy; my $t = dclone($r->{sync}); return ("", [$t, $self->{ext}], $r, $self, $r->{ext}); } sub STORABLE_thaw { my $self = shift; my ($cloning, $undef, $a, $r, $obj, $ext) = @_; die "STORABLE_thaw #1" unless $obj eq $self; die "STORABLE_thaw #2" unless ref $a eq 'ARRAY'; die "STORABLE_thaw #3" unless ref $r eq 'HASH'; die "STORABLE_thaw #4" unless $a->[1] == $r->{ext}; $self->{ok} = $self; ($self->{sync}, $self->{ext}) = @$a; } package OBJ_REAL2; use Storable qw(freeze thaw); $MAX = 20; $recursed = 0; $hook_called = 0; sub make { bless [], shift } sub STORABLE_freeze { my $self = shift; $hook_called++; return (freeze($self), $self) if ++$recursed < $MAX; return ("no", $self); } sub STORABLE_thaw { my $self = shift; my $cloning = shift; my ($x, $obj) = @_; die "STORABLE_thaw #1" unless $obj eq $self; $self->[0] = thaw($x) if $x ne "no"; $recursed--; } package main; my $real = OBJ_REAL->make; my $x = freeze $real; isnt($x, undef); my $y = thaw $x; is(ref $y, 'OBJ_REAL'); is($y->[0], 'a'); is($y->[1], 1); my $sync = OBJ_SYNC->make; $x = freeze $sync; isnt($x, undef); $y = thaw $x; is(ref $y, 'OBJ_SYNC'); is($y->{ok}, $y); my $ext = [1, 2]; $sync = OBJ_SYNC2->make($ext); $x = freeze [$sync, $ext]; isnt($x, undef); my $z = thaw $x; $y = $z->[0]; is(ref $y, 'OBJ_SYNC2'); is($y->{ok}, $y); is(ref $y->{sync}, 'OBJ_SYNC'); is($y->{ext}, $z->[1]); $real = OBJ_REAL2->make; $x = freeze $real; isnt($x, undef); is($OBJ_REAL2::recursed, $OBJ_REAL2::MAX); is($OBJ_REAL2::hook_called, $OBJ_REAL2::MAX); $y = thaw $x; is(ref $y, 'OBJ_REAL2'); is($OBJ_REAL2::recursed, 0); $x = dclone $real; isnt($x, undef); is(ref $x, 'OBJ_REAL2'); is($OBJ_REAL2::recursed, 0); is($OBJ_REAL2::hook_called, 2 * $OBJ_REAL2::MAX); is(Storable::is_storing, ''); is(Storable::is_retrieving, ''); # # The following was a test-case that Salvador Ortiz Garcia <sog@msg.com.mx> # sent me, along with a proposed fix. # package Foo; sub new { my $class = shift; my $dat = shift; return bless {dat => $dat}, $class; } package Bar; sub new { my $class = shift; return bless { a => 'dummy', b => [ Foo->new(1), Foo->new(2), # Second instance of a Foo ] }, $class; } sub STORABLE_freeze { my($self,$clonning) = @_; return "$self->{a}", $self->{b}; } sub STORABLE_thaw { my($self,$clonning,$dummy,$o) = @_; $self->{a} = $dummy; $self->{b} = $o; } package main; my $bar = new Bar; my $bar2 = thaw freeze $bar; is(ref($bar2), 'Bar'); is(ref($bar->{b}[0]), 'Foo'); is(ref($bar->{b}[1]), 'Foo'); is(ref($bar2->{b}[0]), 'Foo'); is(ref($bar2->{b}[1]), 'Foo'); # # The following attempts to make sure blessed objects are blessed ASAP # at retrieve time. # package CLASS_1; sub make { my $self = bless {}, shift; return $self; } package CLASS_2; sub make { my $self = bless {}, shift; my ($o) = @_; $self->{c1} = CLASS_1->make(); $self->{o} = $o; $self->{c3} = bless CLASS_1->make(), "CLASS_3"; $o->set_c2($self); return $self; } sub STORABLE_freeze { my($self, $clonning) = @_; return "", $self->{c1}, $self->{c3}, $self->{o}; } sub STORABLE_thaw { my($self, $clonning, $frozen, $c1, $c3, $o) = @_; main::is(ref $self, "CLASS_2"); main::is(ref $c1, "CLASS_1"); main::is(ref $c3, "CLASS_3"); main::is(ref $o, "CLASS_OTHER"); $self->{c1} = $c1; $self->{c3} = $c3; } package CLASS_OTHER; sub make { my $self = bless {}, shift; return $self; } sub set_c2 { $_[0]->{c2} = $_[1] } # # Is the reference count of the extra references returned from a # STORABLE_freeze hook correct? [ID 20020601.005 (#9436)] # package Foo2; sub new { my $self = bless {}, $_[0]; $self->{freezed} = "$self"; return $self; } sub DESTROY { my $self = shift; $::refcount_ok = 1 unless "$self" eq $self->{freezed}; } package Foo3; sub new { bless {}, $_[0]; } sub STORABLE_freeze { my $obj = shift; return ("", $obj, Foo2->new); } sub STORABLE_thaw { } # Not really used package main; my $o = CLASS_OTHER->make(); my $c2 = CLASS_2->make($o); my $so = thaw freeze $o; our $refcount_ok = 0; thaw freeze(Foo3->new); is($refcount_ok, 1, "check refcount"); # Check stack overflows [cpan #97526] # JSON::XS limits this to 512. # Small 64bit systems fail with 1200 (c++ debugging), with gcc 3000. # Optimized 64bit allows up to 33.000 recursion depth. # with asan the limit is 255 though. local $Storable::recursion_limit = 30; local $Storable::recursion_limit_hash = 20; sub MAX_DEPTH () { Storable::stack_depth() } sub MAX_DEPTH_HASH () { Storable::stack_depth_hash() } { my $t; print "# max depth ", MAX_DEPTH, "\n"; $t = [$t] for 1 .. MAX_DEPTH; dclone $t; pass "can nest ".MAX_DEPTH." array refs"; } { my $t; $t = {1=>$t} for 1 .. MAX_DEPTH_HASH-10; dclone $t; pass "can nest ".(MAX_DEPTH_HASH)." hash refs"; } { my (@t); push @t, [{}] for 1..5000; #diag 'trying simple array[5000] stack overflow, no recursion'; dclone \@t; is $@, '', 'No simple array[5000] stack overflow #257'; } eval { my $t; $t = [$t] for 1 .. MAX_DEPTH2; eval { note('trying catching recursive aref stack overflow') }; dclone $t; }; like $@, qr/Max\. recursion depth with nested structures exceeded/, 'Caught aref stack overflow '.MAX_DEPTH2; if ($ENV{APPVEYOR} and length(pack "p", "") >= 8) { # TODO: need to repro this fail on a small machine. ok(1, "skip dclone of big hash"); } else { eval { my $t; # 35.000 will cause appveyor 64bit windows to fail earlier $t = {1=>$t} for 1 .. MAX_DEPTH * 2; eval { note('trying catching recursive href stack overflow') }; dclone $t; }; like $@, qr/Max\. recursion depth with nested structures exceeded/, 'Caught href stack overflow '.MAX_DEPTH_HASH2; } { # perl #133326 my @tt; #$Storable::DEBUGME=1; for (1..16000) { my $t = [[[]]]; push @tt, $t; } ok(eval { dclone \@tt; 1 }, "low depth structure shouldn't be treated as nested"); } ��parent.t��0000644��00000006100�15125143206�0006216 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use TestUtils qw/exception/; my $DEBUG; BEGIN { $DEBUG = 0 } BEGIN { if ($DEBUG) { require Path::Class; Path::Class->import } } my $IS_WIN32 = $^O eq 'MSWin32'; use Path::Tiny; use File::Spec::Functions qw/canonpath/; sub canonical { my $d = canonpath(shift); $d =~ s{\\}{/}g; $d .= "/" if $d =~ m{//[^/]+/[^/]+$}; return $d; } my @cases = ( #<<< No perltidy "absolute" => [ "/foo/bar" => "/foo" => "/" => "/" ], "relative" => [ "foo/bar/baz" => "foo/bar" => "foo" => "." => ".." => "../.." => "../../.." ], "absolute with .." => [ "/foo/bar/../baz" => "/foo/bar/.." => "/foo/bar/../.." => "/foo/bar/../../.." ], "relative with .." => [ "foo/bar/../baz" => "foo/bar/.." => "foo/bar/../.." => "foo/bar/../../.." ], "relative with leading .." => [ "../foo/bar" => "../foo" => ".." => "../.." ], "absolute with internal dots" => [ "/foo..bar/baz..bam" => "/foo..bar" => "/" ], "relative with internal dots" => [ "foo/bar..baz/wib..wob" => "foo/bar..baz" => "foo" => "." => ".." ], "absolute with leading dots" => [ "/..foo/..bar" => "/..foo" => "/" ], "relative with leading dots" => [ "..foo/..bar/..wob" => "..foo/..bar" => "..foo" => "." => ".." ], "absolute with trailing dots" => [ "/foo../bar.." => "/foo.." => "/" ], "relative with trailing dots" => [ "foo../bar../wob.." => "foo../bar.." => "foo.." => "." => ".." ], #>>> ); my @win32_cases = ( #<<< No perltidy "absolute with drive" => [ "C:/foo/bar" => "C:/foo" => "C:/" => "C:/" ], "absolute with drive and .." => [ "C:/foo/bar/../baz" => "C:/foo" => "C:/" ], "absolute with UNC" => [ "//server/share/foo/bar" => "//server/share/foo" => "//server/share/" => "//server/share/" ], "absolute with drive, UNC and .." => [ "//server/share/foo/bar/../baz" => "//server/share/foo" => "//server/share/" ], #>>> ); push @cases, @win32_cases if $IS_WIN32; while (@cases) { my ( $label, $list ) = splice( @cases, 0, 2 ); subtest $label => sub { my $path = path( shift @$list ); while (@$list) { for my $i ( undef, 0, 1 .. @$list ) { my $n = ( defined $i && $i > 0 ) ? $i : 1; my $expect = $list->[ $n - 1 ]; my $got = $path->parent($i); my $s = defined($i) ? $i : "undef"; is( $got, canonical($expect), "parent($s): $path -> $got" ); is( dir("$path")->parent, canonical($expect), "Path::Class agrees" ) if $DEBUG; } $path = $path->parent; shift @$list; } if ( $path !~ m{\Q..\E} ) { ok( $path->is_rootdir, "final path is root directory" ); } }; } done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��rel-abs.t��0000644��00000017605�15125143206�0006266 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use TestUtils qw/exception pushd tempd has_symlinks/; use Path::Tiny; # absolute() tests my $rel1 = path("."); my $abs1 = $rel1->absolute; is( $abs1->absolute, $abs1, "absolute of absolute is identity" ); my $rel2 = $rel1->child("t"); my $abs2 = $rel2->absolute; is( $rel2->absolute($abs1), $abs2, "absolute on base" ); # Note: in following relative() tests, capital 'A', 'B' denotes absolute path # and lower case 'a', 'b' denotes relative paths. 'R' denotes the root # directory. When there are multiple # letters together, they indicate how paths relate in the hierarchy: # A subsumes AB, ABC and ABD have a common prefix (referred to as AB). # The presence of an underscore indicates a symlink somewhere in that segment # of a path: ABC_D indicates a symlink somewhere between ABC and ABC_D. my @symlink_free_cases = ( # identical (absolute and relative cases) [ "A->rel(A)", "/foo/bar", "/foo/bar", "." ], [ "a->rel(a)", "foo/bar", "foo/bar", "." ], # descends -- absolute [ "AB->rel(A)", "/foo/bar/baz", "/", "foo/bar/baz" ], [ "AB->rel(A)", "/foo/bar/baz", "/foo", "bar/baz" ], [ "AB->rel(A)", "/foo/bar/baz", "/foo/bar", "baz" ], # descends -- relative [ "ab->rel(a)", "foo/bar/baz", "", "foo/bar/baz" ], [ "ab->rel(a)", "foo/bar/baz", ".", "foo/bar/baz" ], [ "ab->rel(a)", "foo/bar/baz", "foo", "bar/baz" ], [ "ab->rel(a)", "foo/bar/baz", "foo/bar", "baz" ], # common prefix -- absolute (same volume) [ "R->rel(A)", "/", "/bam", ".." ], [ "R->rel(AB)", "/", "/bam/baz", "../.." ], [ "ABC->rel(D)", "/foo/bar/baz", "/bam", "../foo/bar/baz" ], [ "ABC->rel(AD)", "/foo/bar/baz", "/foo/bam", "../bar/baz" ], [ "ABC->rel(ABD)", "/foo/bar/baz", "/foo/bar/bam", "../baz" ], [ "ABC->rel(DE)", "/foo/bar/baz", "/bim/bam", "../../foo/bar/baz" ], [ "ABC->rel(ADE)", "/foo/bar/baz", "/foo/bim/bam", "../../bar/baz" ], [ "ABC->rel(ABDE)", "/foo/bar/baz", "/foo/bar/bim/bam", "../../baz" ], # common prefix -- relative (same volume) [ "abc->rel(d)", "foo/bar/baz", "bam", "../foo/bar/baz" ], [ "abc->rel(ad)", "foo/bar/baz", "foo/bam", "../bar/baz" ], [ "abc->rel(abd)", "foo/bar/baz", "foo/bar/bam", "../baz" ], [ "abc->rel(de)", "foo/bar/baz", "bim/bam", "../../foo/bar/baz" ], [ "abc->rel(ade)", "foo/bar/baz", "foo/bim/bam", "../../bar/baz" ], [ "abc->rel(abde)", "foo/bar/baz", "foo/bar/bim/bam", "../../baz" ], # both paths relative (not identical) [ "ab->rel(a)", "foo/bar", "foo", "bar" ], [ "abc->rel(ab)", "foo/bar/baz", "foo/bim", "../bar/baz" ], [ "a->rel(b)", "foo", "bar", "../foo" ], ); for my $c (@symlink_free_cases) { my ( $label, $path, $base, $result ) = @$c; is( path($path)->relative($base), $result, $label ); } my @one_rel_from_root = ( [ "A->rel(b) from rootdir", "/foo/bar", "baz", "../foo/bar" ], [ "a->rel(B) from rootdir", "foo/bar", "/baz", "../foo/bar" ], ); { my $wd = pushd("/"); for my $c (@one_rel_from_root) { my ( $label, $path, $base, $result ) = @$c; is( path($path)->relative($base), $result, $label ); } } { my $wd = tempd("/"); my $cwd = Path::Tiny::cwd->realpath; # A->rel(b) from tmpdir -- need to find updir from ./b to root my $base = $cwd->child("baz"); my ( undef, @parts ) = split "/", $base; my $up_to_root = path( "../" x @parts ); is( path("/foo/bar")->relative("baz"), $up_to_root->child("foo/bar"), "A->rel(b) from tmpdir" ); # a->rel(B) from tempdir -- path is .. + cwd + a is( path("foo/bar")->relative("/baz"), path( "..", $cwd->_just_filepath, "foo/bar" ), "a->rel(B) from tmpdir" ); } subtest "relative on absolute paths with symlinks" => sub { my $wd = tempd; my $cwd = path(".")->realpath; my $deep = $cwd->child("foo/bar/baz/bam/bim/buz/wiz/was/woz"); $deep->mkdir(); plan skip_all => "No symlink support" unless has_symlinks(); my ( $path, $base, $expect ); # (a) symlink in common path # # A_BCD->rel(A_BEF) - common point A_BC - result: ../../C/D # $cwd->child("A")->mkdir; symlink $deep, "A/B" or die "$!"; $path = $cwd->child("A/B/C/D"); $path->mkdir; is( $path->relative( $cwd->child("A/B/E/F") ), "../../C/D", "A_BCD->rel(A_BEF)" ); $cwd->child("A")->remove_tree; $deep->remove_tree; $deep->mkdir; # (b) symlink in path from common to original path # # ABC_DE->rel(ABFG) - common point AB - result: ../../C/D/E # $cwd->child("A/B/C")->mkdir; symlink $deep, "A/B/C/D" or die "$!"; $path = $cwd->child("A/B/C/D/E"); $path->mkdir; is( $path->relative( $cwd->child("A/B/F/G") ), "../../C/D/E", "ABC_DE->rel(ABC_FG)" ); $cwd->child("A")->remove_tree; $deep->remove_tree; $deep->mkdir; # (c) symlink in path from common to new base; all path exist # # ABCD->rel(ABE_FG) - common point AB - result depends on E_F resolution # $path = $cwd->child("A/B/C/D"); $path->mkdir; $cwd->child("A/B/E")->mkdir; symlink $deep, "A/B/E/F" or die $!; $base = $cwd->child("A/B/E/F/G"); $base->mkdir; $expect = $path->relative( $deep->child("G") ); is( $path->relative($base), $expect, "ABCD->rel(ABE_FG) [real paths]" ); $cwd->child("A")->remove_tree; $deep->remove_tree; $deep->mkdir; # (d) symlink in path from common to new base; paths after symlink # don't exist # # ABCD->rel(ABE_FGH) - common point AB - result depends on E_F resolution # $path = $cwd->child("A/B/C/D"); $path->mkdir; $cwd->child("A/B/E")->mkdir; symlink $deep, "A/B/E/F" or die $!; $base = $cwd->child("A/B/E/F/G/H"); $expect = $path->relative( $deep->child("G/H") ); is( $path->relative($base), $expect, "ABCD->rel(ABE_FGH) [unreal paths]" ); $cwd->child("A")->remove_tree; $deep->remove_tree; $deep->mkdir; # (e) symlink at end of common, with updir at start of new base # # AB_CDE->rel(AB_C..FG) - common point really AB - result depends on # symlink resolution # $cwd->child("A/B")->mkdir; symlink $deep, "A/B/C" or die "$!"; $path = $cwd->child("A/B/C/D/E"); $path->mkdir; $base = $cwd->child("A/B/C/../F/G"); $base->mkdir; $expect = $path->relative( $deep->parent->child("F/G")->realpath ); is( $path->relative($base), $expect, "AB_CDE->rel(AB_C..FG)" ); $cwd->child("A")->remove_tree; $deep->remove_tree; $deep->mkdir; # (f) updirs in new base [files exist] # # ABCDE->rel(ABF..GH) - common point AB - result ../../C/D/E # $path = $cwd->child("A/B/C/D/E"); $path->mkdir; $cwd->child("A/B/F")->mkdir; $cwd->child("A/B/G/H")->mkdir; $base = $cwd->child("A/B/F/../G/H"); $expect = "../../C/D/E"; is( $path->relative($base), $expect, "ABCDE->rel(ABF..GH) [real paths]" ); $cwd->child("A")->remove_tree; # (f) updirs in new base [files don't exist] # # ABCDE->rel(ABF..GH) - common point AB - result ../../C/D/E # $path = $cwd->child("A/B/C/D/E"); $base = $cwd->child("A/B/F/../G/H"); $expect = "../../C/D/E"; is( $path->relative($base), $expect, "ABCDE->rel(ABF..GH) [unreal paths]" ); $cwd->child("A")->remove_tree; }; # XXX need to test common prefix case where both are abs but one # has volume and one doesn't. (Win32: UNC and drive letters) # XXX need to test A->rel(B) where A and B are different volumes, # including UNC and drive letters done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��data/chmod.txt��0000644��00000142261�15125143206�0007315 0��ustar�00�� au=w,uo=x,go=wx 00777 00133 augo-rw,ug=rwx 00000 00770 augo-rw,ug=rwx 00777 00771 go+rwx 00000 00077 go+rwx 00777 00777 u=wx,ao=wx,go=rwx 00777 00377 augo=x,aug-rw 00777 00111 ug-w 00000 00000 ug-w 00777 00557 o+rx,uo-rw,au+wx 00777 00373 o+rx,uo-rw,au+wx 00000 00333 ugo=wx,auo=r,augo-x 00777 00444 a-x,u-rw,aug=rw 00777 00666 auo=rwx,u=x,ag-r 00777 00133 ugo+rw 00777 00777 ugo+rw 00000 00666 au=rwx 00777 00777 a-w,auo+r,ag=r 00777 00444 ao=rwx,ago-rwx 00777 00000 g=rwx 00000 00070 g=rwx 00777 00777 auo-w,go+rw 00000 00066 auo-w,go+rw 00777 00577 ao+rx 00777 00777 ao+rx 00000 00555 ugo+rwx,aug=x 00777 00111 auo+rw,o-rwx,ago=rw 00777 00666 uo+x 00777 00777 uo+x 00000 00101 u=w 00000 00200 u=w 00777 00277 ug=rw,ago+x,uo=rx 00777 00575 ag+rw 00000 00666 ag+rw 00777 00777 auo=x 00777 00111 augo+wx,uo+wx,o-w 00777 00775 augo+wx,uo+wx,o-w 00000 00331 a+rw 00000 00666 a+rw 00777 00777 ago-r,ug+wx 00000 00330 ago-r,ug+wx 00777 00333 g=rx,augo=rx 00777 00555 u=rwx,auo+rx,ug+rw 00000 00775 u=rwx,auo+rx,ug+rw 00777 00777 go+w 00000 00022 go+w 00777 00777 ugo=w,aug=rw,auo=rx 00777 00555 ago-r 00777 00333 ago-r 00000 00000 o-wx 00777 00774 o-wx 00000 00000 o+x,a+wx 00777 00777 o+x,a+wx 00000 00333 au-rw,auo+wx,ug+rw 00777 00773 augo=rw,aug=wx 00777 00333 augo+x,ugo-rwx 00777 00000 o-rwx,go+w 00777 00772 o-rwx,go+w 00000 00022 ag-rx 00777 00222 ag-rx 00000 00000 auo=rw,g+rx 00777 00676 aug+rwx,ug-rx,ao+rw 00777 00667 u-x,a-r 00000 00000 u-x,a-r 00777 00233 au+x 00000 00111 au+x 00777 00777 ao=w,augo=rx,aug-rwx 00777 00000 aug-rwx 00777 00000 a+rx,ug-x,ao+rx 00777 00777 a+rx,ug-x,ao+rx 00000 00555 go=x 00000 00011 go=x 00777 00711 ugo-rx,ago+rx 00000 00555 ugo-rx,ago+rx 00777 00777 go-wx,augo-wx,u+x 00777 00544 go-wx,augo-wx,u+x 00000 00100 au-rw,augo+rw 00000 00666 au-rw,augo+rw 00777 00777 ag-rx,au-w,ugo+x 00777 00111 augo=x,auo+wx,u-x 00777 00233 aug+x,auo+rx 00777 00777 aug+x,auo+rx 00000 00555 aug-w,a-rx 00777 00000 ugo=rx 00777 00555 au-wx,ugo-rwx,u+r 00777 00400 ug=rw,au+rwx 00777 00777 go=rw,o=w,ao-rw 00777 00100 go=rw,o=w,ao-rw 00000 00000 ugo+wx 00777 00777 ugo+wx 00000 00333 ug=x,o=rw,uo+r 00777 00516 augo+r,au+x 00777 00777 augo+r,au+x 00000 00555 g=r,ao+w 00777 00767 g=r,ao+w 00000 00262 augo+w,a+w,ug=rx 00000 00552 augo+w,a+w,ug=rx 00777 00557 ugo=rwx,ago+w,aug-rx 00777 00222 aug-rw,augo=w,ago=x 00777 00111 auo=x,ao-w 00777 00111 ug-x,ugo-w 00777 00445 ug-x,ugo-w 00000 00000 ao-rwx,a=rwx,ag-rw 00777 00111 ag=rwx,aug+r 00777 00777 go+rw,uo+x 00000 00167 go+rw,uo+x 00777 00777 ugo+w 00000 00222 ugo+w 00777 00777 ug+r 00000 00440 ug+r 00777 00777 u-r 00000 00000 u-r 00777 00377 ao=rwx,ug=r 00777 00447 o+wx,g-r 00000 00003 o+wx,g-r 00777 00737 uo+w 00000 00202 uo+w 00777 00777 ag-rw,g=r,auo-rx 00777 00000 au=w,ug-rx 00777 00222 a+rw,auo+wx,auo+rx 00777 00777 aug-r 00000 00000 aug-r 00777 00333 uo+r 00000 00404 uo+r 00777 00777 ago-x 00000 00000 ago-x 00777 00666 aug-rwx,augo+r 00777 00444 ag=rw,ao-rw,a=rx 00777 00555 ago=x,ugo=x,aug=rwx 00777 00777 ag+w 00777 00777 ag+w 00000 00222 o=r,ugo=r,ao=r 00777 00444 ao-wx,g-w 00777 00444 ao-wx,g-w 00000 00000 au-r,o-wx 00000 00000 au-r,o-wx 00777 00330 ag=rw,ago=x,aug-rx 00777 00000 aug+r,a-rwx,u-x 00777 00000 u-x,ag+wx,go-x 00000 00322 u-x,ag+wx,go-x 00777 00766 a-rw,a-w,ag=rx 00777 00555 ago-rw,aug=rwx 00777 00777 aug=r,ag=w 00777 00222 g-x,a=rw 00777 00666 ug+rwx 00000 00770 ug+rwx 00777 00777 aug+x,go=x 00777 00711 aug+x,go=x 00000 00111 ago=x,aug+x 00777 00111 go=rwx 00000 00077 go=rwx 00777 00777 au+rw,ugo=w,augo-rw 00777 00000 ag=rwx 00777 00777 augo=rx,go=rw 00777 00566 ag-rwx,o+rx,u=rx 00777 00505 ugo=x,auo+wx,ug-rx 00777 00223 u-wx,u-r,go-r 00000 00000 u-wx,u-r,go-r 00777 00033 au=rwx,aug=rw 00777 00666 au-wx 00777 00444 au-wx 00000 00000 aug=rwx,ao-rw 00777 00111 g+wx 00000 00030 g+wx 00777 00777 auo+wx,ago-x 00777 00666 auo+wx,ago-x 00000 00222 auo-rw,uo=wx 00777 00313 auo-rw,uo=wx 00000 00303 uo-wx,ao-rx 00777 00020 uo-wx,ao-rx 00000 00000 aug+rx,uo-x,ago=r 00777 00444 aug=rwx,g=rwx,aug=wx 00777 00333 ago+rx,ug-rwx,o+w 00777 00007 ago-rw 00777 00111 ago-rw 00000 00000 ao=w,o+rx,u=wx 00777 00327 au+w,ago-w 00777 00555 au+w,ago-w 00000 00000 au+x,aug+wx 00000 00333 au+x,aug+wx 00777 00777 ug=x,u=x 00000 00110 ug=x,u=x 00777 00117 ugo=wx,au=r,au+rwx 00777 00777 ug=wx 00000 00330 ug=wx 00777 00337 o-r,ago=x,a+wx 00777 00333 ago+rx,o-wx,au-rw 00777 00110 o+w,auo=rx 00777 00555 auo=wx,ao-rwx,au=rx 00777 00555 ag+x,ao+w 00000 00333 ag+x,ao+w 00777 00777 u=rw 00000 00600 u=rw 00777 00677 aug+w,o-x 00000 00222 aug+w,o-x 00777 00776 u+wx,ao=rwx,o+w 00777 00777 a+rw,ag+rx 00777 00777 g-rx 00000 00000 g-rx 00777 00727 g-w,au-rx,a+wx 00777 00333 u=r,ago+x,augo+w 00000 00733 u=r,ago+x,augo+w 00777 00777 ug-r,g-x,ago+x 00777 00337 ug-r,g-x,ago+x 00000 00111 u-w,ag-x 00000 00000 u-w,ag-x 00777 00466 go+x 00000 00011 go+x 00777 00777 g+x,ao-x 00777 00666 g+x,ao-x 00000 00000 augo+r,o=rw,aug-rw 00777 00110 augo+r,o=rw,aug-rw 00000 00000 aug+wx,o=r 00000 00334 aug+wx,o=r 00777 00774 u=rwx,o-wx,augo-rw 00777 00110 u=rwx,o-wx,augo-rw 00000 00100 ug-w,a=x,g=rx 00777 00151 g+rx,g+rwx,go-r 00777 00733 g+rx,g+rwx,go-r 00000 00030 au=w 00777 00222 augo-w,auo-x,ao-wx 00000 00000 augo-w,auo-x,ao-wx 00777 00444 ugo-rw,ao+x,ag-x 00777 00000 ugo=w,ago-r 00777 00222 auo-rw,aug=wx,aug-rw 00777 00111 aug-x,o-rx 00777 00662 aug-x,o-rx 00000 00000 ug+rwx,o+rw 00000 00776 ug+rwx,o+rw 00777 00777 auo-rw,augo=rwx,augo=rw 00777 00666 uo=rw,au+x 00000 00717 uo=rw,au+x 00777 00777 ug-r,ago-rx,o+wx 00777 00223 ug-r,ago-rx,o+wx 00000 00003 u=rw,augo=rw,ag+rx 00777 00777 u+wx,o-rw,augo=w 00777 00222 uo=wx,g-r,ao=x 00777 00111 g=w,go-rw,au+x 00777 00711 g=w,go-rw,au+x 00000 00111 auo+x,uo-rwx 00777 00070 auo+x,uo-rwx 00000 00010 o-w 00000 00000 o-w 00777 00775 ugo=w,ao-rw 00777 00000 a=rw 00777 00666 ao-rx,ugo-rw,auo+rwx 00777 00777 ao=rx,au+wx,augo-rw 00777 00111 a=rwx,ao+r,au+w 00777 00777 u+w,u-rwx,augo+r 00777 00477 u+w,u-rwx,augo+r 00000 00444 ugo=rwx 00777 00777 go-w,ug=rw,au+w 00000 00662 go-w,ug=rw,au+w 00777 00667 aug+w,auo=rx 00777 00555 ag=r 00777 00444 ug-r,augo-r,ugo-rx 00000 00000 ug-r,augo-r,ugo-rx 00777 00222 u-rwx,ago=x 00777 00111 u-wx,ugo=wx,ao+x 00777 00333 ao=rw 00777 00666 g=x,auo=r 00777 00444 go=rw 00000 00066 go=rw 00777 00766 a+rx 00000 00555 a+rx 00777 00777 au-rx,go=r 00000 00044 au-rx,go=r 00777 00244 augo-x,ag+rw,ago=rwx 00777 00777 g=rx 00777 00757 g=rx 00000 00050 ug+rwx,augo-wx,aug=wx 00777 00333 ugo-wx,aug=rx 00777 00555 au+r 00777 00777 au+r 00000 00444 au+x,au+w 00000 00333 au+x,au+w 00777 00777 go+x,ug-x,uo+rx 00777 00767 go+x,ug-x,uo+rx 00000 00505 ago-rx,ug+x 00000 00110 ago-rx,ug+x 00777 00332 a=r,ag+r,go+wx 00777 00477 g=r 00000 00040 g=r 00777 00747 ugo+w,ago=r,auo+rx 00777 00555 ago=r,ao+rwx,ugo+wx 00777 00777 a-rw,ag=r 00777 00444 ugo+rwx 00777 00777 a+rx,o-w 00000 00555 a+rx,o-w 00777 00775 ao+r,o+r 00000 00444 ao+r,o+r 00777 00777 o=rw,augo+rwx,au=rw 00777 00666 ago-rw,u=w,ao=rwx 00777 00777 u+rw,go=rx,ag+rw 00777 00777 u+rw,go=rx,ag+rw 00000 00677 u=rx,a+wx 00000 00733 u=rx,a+wx 00777 00777 ugo+rx 00000 00555 ugo+rx 00777 00777 uo=rw 00777 00676 uo=rw 00000 00606 a+rwx,aug=wx,auo-r 00777 00333 uo+wx 00777 00777 uo+wx 00000 00303 a-rw,ao+r 00777 00555 a-rw,ao+r 00000 00444 ugo-rx,au-r,ao+x 00000 00111 ugo-rx,au-r,ao+x 00777 00333 ag-rx,a-rwx 00777 00000 ago+wx,uo-rx 00000 00232 ago+wx,uo-rx 00777 00272 ago-r,g=rw,ao=rwx 00777 00777 ug+x,go=rw 00777 00766 ug+x,go=rw 00000 00166 g+rw,auo=x 00777 00111 augo=rx 00777 00555 ag-r,go=r 00777 00344 ag-r,go=r 00000 00044 aug=x 00777 00111 go-r,u=wx 00000 00300 go-r,u=wx 00777 00333 ugo-wx,a=rw,augo-rx 00777 00222 augo+rwx,au=w 00777 00222 ag=x,aug-w 00777 00111 ug=x,u=r,auo=r 00777 00444 o+rwx,ugo=r,a+rw 00777 00666 ug-wx 00777 00447 ug-wx 00000 00000 uo-x,aug+w 00000 00222 uo-x,aug+w 00777 00676 au+rw,ago-x 00777 00666 ug=rw,go=x 00777 00611 ug=rx,ago=rwx,g-rwx 00777 00707 au=rwx,ugo+w,ao=rwx 00777 00777 augo-rx,ug+w 00000 00220 augo-rx,ug+w 00777 00222 ao+x,ugo=wx,au+rw 00777 00777 ug=wx,u=w 00000 00230 ug=wx,u=w 00777 00237 ago+x,au-rw 00777 00111 augo+r,aug=rx 00777 00555 ao=rw,ug+wx 00777 00776 ag-w,augo-w 00777 00555 ag-w,augo-w 00000 00000 o-rwx 00000 00000 o-rwx 00777 00770 ugo-w 00000 00000 ugo-w 00777 00555 ugo+rw,uo-w,aug=r 00777 00444 ago=rwx,ag-rx 00777 00222 o=x,uo-x,auo-x 00777 00660 o=x,uo-x,auo-x 00000 00000 g-rx,au-x,ago+r 00777 00666 g-rx,au-x,ago+r 00000 00444 go+rw 00777 00777 go+rw 00000 00066 u-wx,augo=w,go-rx 00777 00222 aug=wx,ago=r,auo-r 00777 00000 au+rx,go=wx 00000 00533 au+rx,go=wx 00777 00733 au-rx 00000 00000 au-rx 00777 00222 augo+rw 00000 00666 augo+rw 00777 00777 ao=wx,augo-rx,aug=w 00777 00222 o+wx,o+rx 00777 00777 o+wx,o+rx 00000 00007 o-wx,uo-x 00777 00674 o-wx,uo-x 00000 00000 ao+rw 00777 00777 ao+rw 00000 00666 g+x,ago-rx,a+rwx 00777 00777 ao+rwx,u-wx 00777 00477 aug=r,a-w 00777 00444 ago=x,g+rx,ago=wx 00777 00333 uo+rw,au+r 00000 00646 uo+rw,au+r 00777 00777 aug-wx,o-x 00777 00444 aug-wx,o-x 00000 00000 ao+w 00777 00777 ao+w 00000 00222 u=x,g+rwx,au=x 00777 00111 uo=rw,au=x,g+r 00777 00151 au+rw 00000 00666 au+rw 00777 00777 ao=r,go=rx,ag=rx 00777 00555 ug=rx,ago+w,aug+wx 00000 00773 ug=rx,ago+w,aug+wx 00777 00777 au+rwx,au+rwx,go-rx 00777 00722 uo+wx,ag-wx,augo=rx 00777 00555 o+rx,augo+rw 00000 00667 o+rx,augo+rw 00777 00777 o-rx,ao+wx,ao=wx 00777 00333 uo+rw,a-w 00000 00404 uo+rw,a-w 00777 00555 ug+wx 00000 00330 ug+wx 00777 00777 ago-x,ago=rx,ao-rw 00777 00111 ao-rw,auo=w,ag-x 00777 00222 go+rx,ugo+rwx 00777 00777 o+rwx,o+rx,g-rx 00777 00727 o+rwx,o+rx,g-rx 00000 00007 a=x,augo=r 00777 00444 auo-rw 00000 00000 auo-rw 00777 00111 augo=rx,go=r 00777 00544 ag+r,ugo-rw 00000 00000 ag+r,ugo-rw 00777 00111 auo-rx,a+rx 00000 00555 auo-rx,a+rx 00777 00777 ug+rw 00777 00777 ug+rw 00000 00660 auo=rx,auo-rx 00777 00000 aug+w,aug-rw,ago=x 00777 00111 ugo=r,aug=wx,a-w 00777 00111 ago=rx 00777 00555 u-rw,go+rwx,ugo=x 00777 00111 o=rw,uo+wx,aug=r 00777 00444 ug+wx,aug=rx 00777 00555 u=x,ago-wx,ag=rw 00777 00666 aug=rwx 00777 00777 uo+x,aug-rw,ug=r 00777 00441 uo-r,o-rw 00000 00000 uo-r,o-rw 00777 00371 g+rw 00777 00777 g+rw 00000 00060 uo+rw,au=x 00777 00111 ug-w,ao-wx 00777 00444 ug-w,ao-wx 00000 00000 a=rx,ag-r,ago-w 00777 00111 go-rwx,go=rw 00000 00066 go-rwx,go=rw 00777 00766 o+rw 00000 00006 o+rw 00777 00777 ao+x,a=r,ao+rw 00777 00666 aug+x,ao-x 00777 00666 aug+x,ao-x 00000 00000 uo=r,ug+wx,g+w 00000 00734 uo=r,ug+wx,g+w 00777 00774 o-rw,auo=r,augo=rw 00777 00666 au=w,ago-wx,g=rwx 00777 00070 a+wx,ug-x,aug=x 00777 00111 ug-wx,ugo=r 00777 00444 ag-r,g-r,go=wx 00000 00033 ag-r,g-r,go=wx 00777 00333 ag-x,aug+x 00777 00777 ag-x,aug+x 00000 00111 augo=r 00777 00444 go+wx,ao=x,ao+rw 00777 00777 au+x,ag-rx,o=wx 00000 00003 au+x,ag-rx,o=wx 00777 00223 a+x,ago+rwx,uo=rx 00777 00575 ug-rw 00777 00117 ug-rw 00000 00000 u=w,go-w,ao+wx 00777 00377 u=w,go-w,ao+wx 00000 00333 uo-rwx,g-rwx 00777 00000 ago+r,ago+rwx,ago=r 00777 00444 auo=w,o+rx 00777 00227 go+wx,u+rx,uo-wx 00000 00430 go+wx,u+rx,uo-wx 00777 00474 ao+x 00777 00777 ao+x 00000 00111 ag-rw,a-rw,ao+rx 00777 00555 auo-r 00777 00333 auo-r 00000 00000 o+rw,ag=rw,o=x 00777 00661 go=rwx,go+rwx,ag=rx 00777 00555 aug=rx,auo-rwx,augo=r 00777 00444 ao-rwx,au=w,u+rwx 00777 00722 aug+w 00777 00777 aug+w 00000 00222 o-rw 00000 00000 o-rw 00777 00771 go+rwx,ug=rwx 00777 00777 auo+rx,au-w 00777 00555 a-wx 00777 00444 a-wx 00000 00000 au=rwx,go+rwx 00777 00777 o+rx 00000 00005 o+rx 00777 00777 g=wx 00777 00737 g=wx 00000 00030 ago=r 00777 00444 auo=rw,go-r,go-rx 00777 00622 ugo=wx,ago=rx,o+wx 00777 00557 go=rwx,ago+x,a+r 00000 00577 go=rwx,ago+x,a+r 00777 00777 ag-wx 00000 00000 ag-wx 00777 00444 o-wx,uo-rwx 00000 00000 o-wx,uo-rwx 00777 00070 u-wx 00777 00477 u-wx 00000 00000 u+rwx,ugo-x,u-x 00777 00666 u+rwx,ugo-x,u-x 00000 00600 ugo=rw 00777 00666 au+rx,g=w,auo=w 00777 00222 a-wx,ago-x 00000 00000 a-wx,ago-x 00777 00444 u+rw,au-rwx 00777 00000 augo-wx,aug+wx 00000 00333 augo-wx,aug+wx 00777 00777 g+r 00777 00777 g+r 00000 00040 aug=rwx,augo-rx 00777 00222 ug=w,aug+rwx,uo=rx 00777 00575 a=rwx 00777 00777 ugo=r,g-r,a=wx 00777 00333 g+rwx 00000 00070 g+rwx 00777 00777 au=x,a-wx,au+x 00777 00111 go-x,ao-r,ag=x 00777 00111 ao=r,ao+rx 00777 00555 ag+w,ao-rw,ag+wx 00777 00333 g+r,o-r,augo-rw 00777 00111 g+r,o-r,augo-rw 00000 00000 go+r 00000 00044 go+r 00777 00777 ao=r,o+rwx 00777 00447 ago=r,go=rwx 00777 00477 ao+rwx,ag+r,ugo-rwx 00777 00000 ao=wx 00777 00333 ago+wx,aug+rwx 00777 00777 ao=wx,aug=wx 00777 00333 ao=w,a-r,ao+rx 00777 00777 aug+w,u-x,auo+wx 00000 00333 aug+w,u-x,auo+wx 00777 00777 o=wx,go=rw,ag=x 00777 00111 uo-rwx,uo-rwx 00000 00000 uo-rwx,uo-rwx 00777 00070 o=x 00000 00001 o=x 00777 00771 ao-rwx 00777 00000 o-x,uo-w,ao=w 00777 00222 au+r,u=r 00777 00477 au+r,u=r 00000 00444 go=rx,g+wx 00000 00075 go=rx,g+wx 00777 00775 ag+w,o+rwx,ago=r 00777 00444 auo-w,u-x 00777 00455 auo-w,u-x 00000 00000 ug-rw,uo-w,aug-rx 00777 00000 a+x,ao+r 00777 00777 a+x,ao+r 00000 00555 ag=rwx,aug-wx 00777 00444 au+w,ugo-rw,ugo+rx 00777 00555 g=rw 00000 00060 g=rw 00777 00767 a-rx 00777 00222 a-rx 00000 00000 ugo-x,ag+rx 00777 00777 ugo-x,ag+rx 00000 00555 auo-rwx,au-rwx,ag+x 00777 00111 uo-w 00000 00000 uo-w 00777 00575 o+rwx 00000 00007 o+rwx 00777 00777 ago-rx 00777 00222 ago-rx 00000 00000 ao+rwx,ao+rw 00777 00777 au=w,ao+wx,g-rx 00777 00323 o-x,g+rw 00777 00776 o-x,g+rw 00000 00060 u+rx,uo+rw 00777 00777 u+rx,uo+rw 00000 00706 ugo-rw 00000 00000 ugo-rw 00777 00111 ag-r,ago=x 00777 00111 go=x,a=x,ago=wx 00777 00333 ao-x 00777 00666 ao-x 00000 00000 u+rw,aug=rw,uo=x 00777 00161 uo+w,ago-rwx 00777 00000 augo=x 00777 00111 ug=x,go+rw 00777 00177 ug=x,go+rw 00000 00176 ugo=rw,ag=w 00777 00222 g+rx,u-w,ug+rx 00777 00577 g+rx,u-w,ug+rx 00000 00550 ug=rx,auo-rwx,u+r 00777 00400 a+rwx,go-w 00777 00755 o-x,auo-rwx,go-x 00777 00000 u-rw,ao=w,u+rx 00777 00722 ugo+x,a=rx,ag=wx 00777 00333 auo+x 00777 00777 auo+x 00000 00111 ugo+wx,ugo+w 00777 00777 ugo+wx,ugo+w 00000 00333 ag+x 00777 00777 ag+x 00000 00111 go-rx,au+rx 00777 00777 go-rx,au+rx 00000 00555 ao+rwx,go+x 00777 00777 a=wx 00777 00333 u+rwx,o+r 00777 00777 u+rwx,o+r 00000 00704 auo=rx,u-rwx 00777 00055 u=x,au-w 00000 00100 u=x,au-w 00777 00155 auo+rwx,ago-rw 00777 00111 ao+x,u=w,g-rw 00777 00217 ao+x,u=w,g-rw 00000 00211 a=w,ag+r,g+w 00777 00666 g-rw 00777 00717 g-rw 00000 00000 augo+x 00000 00111 augo+x 00777 00777 o-rx,g-rwx,ag=rx 00777 00555 augo=rw,aug+r 00777 00666 uo+rwx 00000 00707 uo+rwx 00777 00777 aug-rx,ao+x,uo=rw 00777 00636 aug-rx,ao+x,uo=rw 00000 00616 u-r,ago-rx,ug=rw 00777 00662 u-r,ago-rx,ug=rw 00000 00660 au=wx,ugo+rx,go=x 00777 00711 o-rx,ugo+x,ao-rx 00000 00000 o-rx,ugo+x,ao-rx 00777 00222 augo-w,a=rwx,o-rw 00777 00771 o+wx 00000 00003 o+wx 00777 00777 aug-w,aug+wx 00777 00777 aug-w,aug+wx 00000 00333 ug-rwx,aug-r,augo-rwx 00777 00000 aug+rw 00777 00777 aug+rw 00000 00666 augo+rwx,go-w,ao-w 00777 00555 o-w,o=w 00777 00772 o-w,o=w 00000 00002 o-rwx,ao-x 00000 00000 o-rwx,ao-x 00777 00660 au-x,g-rx,u+r 00000 00400 au-x,g-rx,u+r 00777 00626 ao=wx,au+w 00777 00333 ao=rwx,aug-rwx,au=x 00777 00111 aug+x,a-rwx 00777 00000 go-rx,go+x 00000 00011 go-rx,go+x 00777 00733 au-wx,au-w,ugo+wx 00000 00333 au-wx,au-w,ugo+wx 00777 00777 augo-rx,go-x 00000 00000 augo-rx,go-x 00777 00222 go-rx 00000 00000 go-rx 00777 00722 o+rwx,uo-rwx,augo-rwx 00777 00000 auo=w,ago=rwx,g-r 00777 00737 ago-w 00000 00000 ago-w 00777 00555 aug+wx,ugo-rx,go-r 00777 00222 g-x,auo+x 00777 00777 g-x,auo+x 00000 00111 ao-x,uo-rw,aug-rw 00777 00000 go-x,au=rx 00777 00555 a+r 00777 00777 a+r 00000 00444 ao-rw 00777 00111 ao-rw 00000 00000 ug-rx 00777 00227 ug-rx 00000 00000 ago-rwx 00777 00000 uo-rwx 00777 00070 uo-rwx 00000 00000 ag-rw,o+w 00777 00113 ag-rw,o+w 00000 00002 au=rx,augo=w,go-rwx 00777 00200 g=wx,u=x,a=rx 00777 00555 augo-x,u=wx,a+r 00777 00766 augo-x,u=wx,a+r 00000 00744 go+rwx,ag+rx 00000 00577 go+rwx,ag+rx 00777 00777 ago+rw,a=rx,ug-wx 00777 00445 ago-rx,ago+w,uo=r 00777 00424 auo+wx 00000 00333 auo+wx 00777 00777 ago+w,aug=rwx 00777 00777 a-rx,go+wx,ago-rx 00777 00222 a-rx,go+wx,ago-rx 00000 00022 aug+r 00000 00444 aug+r 00777 00777 aug+rw,ugo+rw,u=wx 00777 00377 aug+rw,ugo+rw,u=wx 00000 00366 a-wx,au-rwx,ag-wx 00777 00000 o+wx,a-x,ugo+rw 00777 00666 u=rwx,uo-x,ugo-rwx 00777 00000 aug-rw 00000 00000 aug-rw 00777 00111 uo=x 00777 00171 uo=x 00000 00101 auo-w,ug+wx,ug-wx 00000 00000 auo-w,ug+wx,ug-wx 00777 00445 uo+rwx,uo=wx 00000 00303 uo+rwx,uo=wx 00777 00373 auo=rw 00777 00666 ug-rw,au-rw,o=rwx 00777 00117 ug-rw,au-rw,o=rwx 00000 00007 ugo-x 00000 00000 ugo-x 00777 00666 ao=wx,ug-rw,augo-rwx 00777 00000 o=w 00000 00002 o=w 00777 00772 a=x,uo-w,ugo-wx 00777 00000 ag-rw 00000 00000 ag-rw 00777 00111 uo=rx,ug-rw,g-wx 00777 00105 go=x,ug-w,uo-wx 00777 00410 go=x,ug-w,uo-wx 00000 00010 uo+r,g-r 00000 00404 uo+r,g-r 00777 00737 au+rwx,g=wx,uo+rx 00777 00737 ao=w,g-rw,aug+x 00777 00313 augo=wx,go-rx 00777 00322 augo+w,go-x,u+rx 00777 00766 augo+w,go-x,u+rx 00000 00722 g=x,ago=rwx 00777 00777 a=w,u=r,o-rw 00777 00420 o+x,auo+rwx,ugo+wx 00777 00777 go=wx,ag=r 00777 00444 a+x,aug=rwx 00777 00777 g=rx,uo+rx 00777 00757 g=rx,uo+rx 00000 00555 auo-wx,aug-w 00777 00444 auo-wx,aug-w 00000 00000 g+rx,go+r 00777 00777 g+rx,go+r 00000 00054 a-r 00000 00000 a-r 00777 00333 a=rw,ao-w 00777 00444 u-rx 00000 00000 u-rx 00777 00277 g-r 00777 00737 g-r 00000 00000 a+w 00000 00222 a+w 00777 00777 au-x,ug-r 00000 00000 au-x,ug-r 00777 00226 go-x 00000 00000 go-x 00777 00766 a+w,aug=x 00777 00111 ao-rw,uo+rx,aug-wx 00777 00404 ago=x,uo-rw,auo=rw 00777 00666 o-rx,ag=rwx 00777 00777 au+wx,ugo+x 00000 00333 au+wx,ugo+x 00777 00777 g+rx 00777 00777 g+rx 00000 00050 ag=rx,o=wx 00777 00553 aug-x 00777 00666 aug-x 00000 00000 ag-r,o=rwx,aug=wx 00777 00333 a+w,ugo+rwx,ug-wx 00777 00447 aug=rwx,ao=rwx,ugo+rw 00777 00777 au-rwx,ao=r,go=r 00777 00444 u=wx,ugo+rwx 00777 00777 ao-x,ag-r 00777 00222 ao-x,ag-r 00000 00000 ugo+r 00777 00777 ugo+r 00000 00444 au=wx,aug=w 00777 00222 go-rw,o+rw 00000 00006 go-rw,o+rw 00777 00717 ug=rwx,augo+wx,a+wx 00000 00773 ug=rwx,augo+wx,a+wx 00777 00777 ag+x,uo-x 00777 00676 ag+x,uo-x 00000 00010 uo=rwx,o+rw 00000 00707 uo=rwx,o+rw 00777 00777 auo=rw,go=wx,ao-rwx 00777 00000 au=rw,ug-rwx,aug-w 00777 00004 uo+rw 00777 00777 uo+rw 00000 00606 g-rwx 00000 00000 g-rwx 00777 00707 auo=r,auo-wx,o+rwx 00777 00447 o-r,au=rw,ag+w 00777 00666 o=rw 00777 00776 o=rw 00000 00006 go+r,auo+rw 00000 00666 go+r,auo+rw 00777 00777 ago-rwx,go=wx,ug-rw 00777 00013 ao=r,uo-rx,a-rwx 00777 00000 ag=wx,uo-r 00777 00333 ag+r,ugo+wx 00777 00777 ag-wx,g=rx 00000 00050 ag-wx,g=rx 00777 00454 ug+rx,ag-rwx 00777 00000 augo=rx,o+wx,au=wx 00777 00333 o+rw,go-rwx 00000 00000 o+rw,go-rwx 00777 00700 ago=rw,au=x,ao=r 00777 00444 ug-rw,a=rwx 00777 00777 go+rwx,ao-rw 00777 00111 go+rwx,ao-rw 00000 00011 ugo+rx,au=rwx 00777 00777 ao+wx,uo-rw,augo+w 00777 00373 ao+wx,uo-rw,augo+w 00000 00333 au=x 00777 00111 ugo+w,ag+rwx 00777 00777 ago=rw,go-r,augo=rwx 00777 00777 ago-rx,ao=wx 00777 00333 au=rx,au=x 00777 00111 augo+rx,go+rwx,aug+r 00000 00577 augo+rx,go+rwx,aug+r 00777 00777 ago=rwx,ag-wx 00777 00444 ag=w,augo-wx 00777 00000 g+rx,ag+rw 00777 00777 g+rx,ag+rw 00000 00676 uo+rx,ugo=w,a+r 00777 00666 au-w,auo+x 00777 00555 au-w,auo+x 00000 00111 aug-w,auo-wx,auo=wx 00777 00333 u=wx,g+w,auo-rwx 00777 00000 auo=w,go-r 00777 00222 ugo-r,u+wx,aug=x 00777 00111 g=r,ug=rw 00000 00660 g=r,ug=rw 00777 00667 uo-rwx,augo=r 00777 00444 augo+rx 00000 00555 augo+rx 00777 00777 ao+rx,ago=x 00777 00111 auo+rw,ag=x,aug=x 00777 00111 a+wx 00777 00777 a+wx 00000 00333 au=x,ugo=wx 00777 00333 auo-w 00777 00555 auo-w 00000 00000 ag-rwx,auo-rx,go+w 00777 00022 ug+rx,ago=w 00777 00222 uo-r,g=rwx,ugo=w 00777 00222 ao=w 00777 00222 auo-rwx 00777 00000 a=rw,u=rx,u-rw 00777 00166 aug-rx,au-r 00777 00222 aug-rx,au-r 00000 00000 uo-r,ago=rx 00777 00555 g+x,uo=rx 00777 00575 g+x,uo=rx 00000 00515 ago=rwx,auo-x,ago=rx 00777 00555 ug+x 00777 00777 ug+x 00000 00110 ug=r,uo-x,au-rwx 00777 00000 ao-rw,ug-wx 00777 00001 ao-rw,ug-wx 00000 00000 ug-r,a+rwx 00777 00777 ugo-wx,ug-wx,ug=wx 00000 00330 ugo-wx,ug-wx,ug=wx 00777 00334 u+w,au-wx,ug=r 00000 00440 u+w,au-wx,ug=r 00777 00444 auo+r,g+w,o+r 00777 00777 auo+r,g+w,o+r 00000 00464 ugo+x 00777 00777 ugo+x 00000 00111 ago-w,aug-rw 00000 00000 ago-w,aug-rw 00777 00111 aug-wx,go=rw 00000 00066 aug-wx,go=rw 00777 00466 ago-rw,go+w,a-w 00000 00000 ago-rw,go+w,a-w 00777 00111 au+w,ao=wx,ug=rwx 00777 00773 uo+rwx,uo+r 00000 00707 uo+rwx,uo+r 00777 00777 ugo+rx,au+rwx,ug-x 00777 00667 o=rwx,g-x 00000 00007 o=rwx,g-x 00777 00767 ug-r,au+wx 00777 00337 ug-r,au+wx 00000 00333 ago=w,augo=r 00777 00444 augo+w 00777 00777 augo+w 00000 00222 a=w,uo+wx 00777 00323 g-rw,aug=x,go-rw 00777 00111 augo-rw,aug=r 00777 00444 auo-rw,augo-rw,ao+rw 00777 00777 auo-rw,augo-rw,ao+rw 00000 00666 auo-rx 00777 00222 auo-rx 00000 00000 u+r,uo=rx,ag=wx 00777 00333 ao=x,uo-w 00777 00111 ugo-rx,ago-rwx,ao+rw 00777 00666 augo=wx,o=x 00777 00331 uo+r,ago+x,au-x 00000 00404 uo+r,ago+x,au-x 00777 00666 au=wx,g-wx,o=rw 00777 00306 auo+r 00777 00777 auo+r 00000 00444 ugo-r 00777 00333 ugo-r 00000 00000 aug=r,au-wx,augo-wx 00777 00444 ago+wx,ago=wx,ao-rwx 00777 00000 au+rx,ugo-x,o-rx 00777 00662 au+rx,ugo-x,o-rx 00000 00440 ugo-rwx,a+w 00777 00222 auo+rwx,o+x 00777 00777 ago+x,ago=w,aug-x 00777 00222 ao+w,uo+rw 00000 00626 ao+w,uo+rw 00777 00777 uo-r 00777 00373 uo-r 00000 00000 uo=rw,ao-rx 00777 00222 uo=rw,ao-rx 00000 00202 u-rw 00777 00177 u-rw 00000 00000 au-rx,a=wx 00777 00333 g-wx 00777 00747 g-wx 00000 00000 ago-x,a+rwx 00777 00777 go=w 00777 00722 go=w 00000 00022 ao=x 00777 00111 ago=w 00777 00222 uo=w,ugo-rx,auo+w 00777 00222 auo-rwx,a=rw 00777 00666 go-r,ago+wx 00777 00733 go-r,ago+wx 00000 00333 a-wx,ao=w,augo=x 00777 00111 ago=wx,u+rw 00777 00733 ao=rx 00777 00555 ag+wx 00777 00777 ag+wx 00000 00333 ago=x,augo=rx 00777 00555 ago+wx,uo+rwx,augo=w 00777 00222 auo=wx 00777 00333 ago+rx 00777 00777 ago+rx 00000 00555 uo-wx,ugo+x,ugo-rw 00777 00111 ago-r,ao+rwx,augo+rx 00777 00777 u+rwx 00777 00777 u+rwx 00000 00700 ugo=r 00777 00444 a+rx,go-rwx,ug=rwx 00777 00770 a=x,ugo-x,ug-r 00777 00000 aug=x,ag=x 00777 00111 au=wx,auo-w 00777 00111 aug=rw,go=w,g-w 00777 00602 u-rwx 00777 00077 u-rwx 00000 00000 uo=r,aug-rx,ao=wx 00777 00333 ugo=x,g+rx 00777 00151 ao-x,au+wx,ag+rx 00777 00777 o=r,au+rwx 00777 00777 aug-rwx,ag=wx 00777 00333 ag+rw,g=x,auo=rx 00777 00555 a=rwx,ugo=wx,au=rwx 00777 00777 ao=rwx,augo-w 00777 00555 ugo=w,au-x,uo-rw 00777 00020 ug+x,u=rx 00777 00577 ug+x,u=rx 00000 00510 ugo+rwx,u+rwx,aug-wx 00777 00444 ugo+x,o=r 00777 00774 ugo+x,o=r 00000 00114 au=w,uo=x 00777 00121 ao=rx,go+rw 00777 00577 ag=x 00777 00111 ug-wx,g-wx 00000 00000 ug-wx,g-wx 00777 00447 aug-x,augo+rw,g=wx 00777 00636 ao+rw,ago=w 00777 00222 ug-rw,u+rwx,ao=rwx 00777 00777 o-rw,ugo-rw 00777 00111 o-rw,ugo-rw 00000 00000 aug+wx,auo-w 00000 00111 aug+wx,auo-w 00777 00555 auo=wx,aug-r 00777 00333 auo=r 00777 00444 ug+w,au-wx,aug-w 00777 00444 ug+w,au-wx,aug-w 00000 00000 ao-rw,auo+rwx,g+w 00777 00777 ugo=rx,go=x 00777 00511 auo-rwx,o-x 00777 00000 auo+rw 00000 00666 auo+rw 00777 00777 ago=rx,ago+rwx,augo-rx 00777 00222 g+x 00000 00010 g+x 00777 00777 o-x,aug+w 00000 00222 o-x,aug+w 00777 00776 a=x,uo=r,a-w 00777 00414 augo+rwx,g+wx 00777 00777 au-rx,ago-rx 00777 00222 au-rx,ago-rx 00000 00000 ao-rx 00000 00000 ao-rx 00777 00222 a+x,ag=wx 00777 00333 auo=rwx 00777 00777 ao-r 00000 00000 ao-r 00777 00333 a=r,ug-w 00777 00444 g+x,ago+rwx,u-rw 00777 00177 ug+rx,go=rw,u=rw 00777 00666 ago-r,ag-rwx,au-w 00777 00000 ago=w,u=rwx 00777 00722 ug-wx,ug+rw 00777 00667 ug-wx,ug+rw 00000 00660 o=x,auo+rwx 00777 00777 aug=wx 00777 00333 ag=rx,ao-rw,g+r 00777 00151 ao+wx 00000 00333 ao+wx 00777 00777 augo=w,augo+r,g-rw 00777 00606 auo=rx,au+rwx,a-wx 00777 00444 au-rw,aug+rx 00777 00555 go+rwx,ago+wx,a=w 00777 00222 augo=rwx,ag-rw 00777 00111 a=rx,a=r,ugo=wx 00777 00333 au-w,aug=wx 00777 00333 uo-wx,au-r 00000 00000 uo-wx,au-r 00777 00030 uo-rx,go+x,g+r 00000 00051 uo-rx,go+x,g+r 00777 00273 ag=r,au=rwx 00777 00777 ug+rwx,ug+wx 00777 00777 ug+rwx,ug+wx 00000 00770 a-w 00000 00000 a-w 00777 00555 u+r 00777 00777 u+r 00000 00400 augo=r,augo+w,uo+r 00777 00666 u+rw,go-rx 00777 00722 u+rw,go-rx 00000 00600 ag=rx 00777 00555 augo-w,u=x,augo=wx 00777 00333 aug-wx,go-x 00000 00000 aug-wx,go-x 00777 00444 ao=x,auo=rwx 00777 00777 uo=rwx 00000 00707 uo=rwx 00777 00777 o-w,au=rw 00777 00666 ugo=w 00777 00222 g-wx,aug+wx,u-x 00777 00677 g-wx,aug+wx,u-x 00000 00233 ag=x,u-wx 00777 00011 g=r,ao=rx 00777 00555 ao+r 00777 00777 ao+r 00000 00444 u+wx 00000 00300 u+wx 00777 00777 ag=rwx,ugo+w 00777 00777 u=rx 00777 00577 u=rx 00000 00500 au=rw,o=rwx,o=wx 00777 00663 ago+x,auo-wx 00777 00444 ago+x,auo-wx 00000 00000 ago+rwx 00777 00777 aug-rwx,ao-rwx 00777 00000 a+rwx,u=r 00777 00477 ag+rw,au+x,ug+rx 00777 00777 o+wx,u+r 00000 00403 o+wx,u+r 00777 00777 ag+x,auo-wx,a=rwx 00777 00777 go-w,ugo-w 00777 00555 go-w,ugo-w 00000 00000 ao=rwx 00777 00777 ago=x 00777 00111 uo+w,ao-r,augo-rwx 00777 00000 auo-wx,go-w 00777 00444 auo-wx,go-w 00000 00000 g-rx,u-r 00000 00000 g-rx,u-r 00777 00327 augo-rwx,a=w,a-w 00777 00000 au=r 00777 00444 aug=rw,auo+x,ugo+rx 00777 00777 ag-x,uo+x 00777 00767 ag-x,uo+x 00000 00101 a+w,ugo+wx 00777 00777 a+w,ugo+wx 00000 00333 augo+rwx 00777 00777 augo-r,o+rx 00777 00337 augo-r,o+rx 00000 00005 ao-wx 00777 00444 ao-wx 00000 00000 au-rw 00000 00000 au-rw 00777 00111 go+rw,au+rx 00000 00577 go+rw,au+rx 00777 00777 ugo+w,augo=rw,aug=rx 00777 00555 ag+rwx 00777 00777 a+rwx,uo+r 00777 00777 ug-w,aug-r 00000 00000 ug-w,aug-r 00777 00113 uo+rx,aug-wx 00777 00444 uo+rx,aug-wx 00000 00404 ao=w,o+wx 00777 00223 uo=rwx,g+rw,u+rx 00000 00767 uo=rwx,g+rw,u+rx 00777 00777 aug-rwx,augo=rx,au-wx 00777 00444 ag-rwx 00777 00000 ug=w,u+x 00000 00320 ug=w,u+x 00777 00327 ug=rwx,g+r 00000 00770 ug=rwx,g+r 00777 00777 g-rwx,au-x 00777 00606 g-rwx,au-x 00000 00000 ao-wx,go=rx 00000 00055 ao-wx,go=rx 00777 00455 ao=x,ug-x,ugo+rx 00777 00555 ug+x,u=r,go+w 00000 00432 ug+x,u=r,go+w 00777 00477 go+rx 00000 00055 go+rx 00777 00777 a=rw,ugo+wx,ago=rw 00777 00666 ug+x,o=r 00777 00774 ug+x,o=r 00000 00114 o+w 00777 00777 o+w 00000 00002 ag+w,go-wx 00777 00744 ag+w,go-wx 00000 00200 u-wx,ago=rwx 00777 00777 ago+r 00000 00444 ago+r 00777 00777 go-wx,auo-rx,ag+r 00000 00444 go-wx,auo-rx,ag+r 00777 00644 auo+w 00777 00777 auo+w 00000 00222 uo-rw,ao=rx,ugo-x 00777 00444 aug+w,o-w 00777 00775 aug+w,o-w 00000 00220 ug=r 00777 00447 ug=r 00000 00440 augo-rw 00000 00000 augo-rw 00777 00111 ag+x,aug+w,au=r 00777 00444 o=r,auo+wx,uo-rw 00777 00171 o=r,auo+wx,uo-rw 00000 00131 ugo-rx,ao+rx,ug+rx 00777 00777 ugo-rx,ao+rx,ug+rx 00000 00555 ao+w,ug-rx 00777 00227 ao+w,ug-rx 00000 00222 a+rwx,go-r 00777 00733 uo=x,ago=wx,ugo+rwx 00777 00777 uo=r 00777 00474 uo=r 00000 00404 o+rw,aug+rx,ugo=rwx 00777 00777 uo-rx 00777 00272 uo-rx 00000 00000 u-rwx,ago+rx 00777 00577 u-rwx,ago+rx 00000 00555 ag-rw,o+w,ug=rx 00777 00553 ag-rw,o+w,ug=rx 00000 00552 u=rw,ago+r,ug=x 00000 00114 u=rw,ago+r,ug=x 00777 00117 aug=w 00777 00222 a=x,ago=rwx,au=rx 00777 00555 ago=rx,ago+x 00777 00555 go-r 00777 00733 go-r 00000 00000 aug=x,augo-rwx,uo+rw 00777 00606 auo-wx,g=rwx,o-x 00000 00070 auo-wx,g=rwx,o-x 00777 00474 auo=rw,uo-rw 00777 00060 go=r 00777 00744 go=r 00000 00044 augo-w,ag-rx 00777 00000 o=w,ag=wx,a=wx 00777 00333 aug=rx 00777 00555 o=w,u-rw 00777 00172 o=w,u-rw 00000 00002 ag-rwx,u=x,o-r 00777 00100 ao+wx,uo=wx 00000 00333 ao+wx,uo=wx 00777 00373 u=wx 00777 00377 u=wx 00000 00300 g-x 00000 00000 g-x 00777 00767 au+rw,o+rx 00000 00667 au+rw,o+rx 00777 00777 ago+x,ug=w,u-x 00000 00221 ago+x,ug=w,u-x 00777 00227 auo+w,au-rwx 00777 00000 ag+rw,ao-rx 00777 00222 ug+w 00777 00777 ug+w 00000 00220 ��basename.t��0000644��00000001560�15125143206�0006505 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use TestUtils qw/exception/; use Path::Tiny; use Cwd; my $IS_WIN32 = $^O eq 'MSWin32'; my @cases = ( [ 'foo.txt', [ '.txt', '.png' ], 'foo' ], [ 'foo.png', [ '.txt', '.png' ], 'foo' ], [ 'foo.txt', [ qr/\.txt/, qr/\.png/ ], 'foo' ], [ 'foo.png', [ qr/\.txt/, qr/\.png/ ], 'foo' ], [ 'foo.txt', ['.jpeg'], 'foo.txt' ], [ 'foo/.txt/bar.txt', [ qr/\.txt/, qr/\.png/ ], 'bar' ], ); for my $c (@cases) { my ( $input, $args, $result ) = @$c; my $path = path($input); my $base = $path->basename(@$args); is( $base, $result, "$path -> $result" ); } done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��fakelib/PerlIO/utf8_strict.pm��0000644��00000000070�15125143206�0012103 0��ustar�00��package PerlIO::utf8_strict; 0; # make require fail ��fakelib/Unicode/UTF8.pm��0000644��00000000062�15125143206�0010610 0��ustar�00��package Unicode::UTF8; 0; # make require fail ��mutable_tree_while_iterating.t��0000644��00000002674�15125143206�0012647 0��ustar�00��use strict; use warnings; use Test::More 0.88; use Path::Tiny; use lib 't/lib'; use TestUtils qw/exception tempd/; use Path::Tiny; my $wd = tempd; my @tree = qw( base/Bethlehem/XDG/gift_list.txt base/Vancouver/ETHER/.naughty base/Vancouver/ETHER/gift_list.txt base/New_York/XDG/gift_list.txt ); path($_)->touchpath for @tree; subtest 'iterator' => sub { my @files; my $iter = path('base')->iterator( { recurse => 1 } ); my $exception = exception { while ( my $path = $iter->() ) { $path->remove_tree if $path->child('.naughty')->is_file; push @files, $path if $path->is_file; } }; is( $exception, '', 'can remove directories while traversing' ); is_deeply( [ sort @files ], [ 'base/Bethlehem/XDG/gift_list.txt', 'base/New_York/XDG/gift_list.txt' ], 'remaining files', ); }; subtest 'visit' => sub { my @files; my $exception = exception { path('base')->visit( sub { my $path = shift; $path->remove_tree if $path->child('.naughty')->is_file; push @files, $path if $path->is_file; }, { recurse => 1 }, ); }; is( $exception, '', 'can remove directories while traversing' ); is_deeply( [ sort @files ], [ 'base/Bethlehem/XDG/gift_list.txt', 'base/New_York/XDG/gift_list.txt' ], 'remaining files', ); }; done_testing; ��exports.t��0000644��00000001242�15125143206�0006433 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use TestUtils qw/exception/; use Path::Tiny qw/path cwd rootdir tempdir tempfile/; isa_ok( path("."), 'Path::Tiny', 'path' ); isa_ok( cwd, 'Path::Tiny', 'cwd' ); isa_ok( rootdir, 'Path::Tiny', 'rootdir' ); isa_ok( tempfile( TEMPLATE => 'tempXXXXXXX' ), 'Path::Tiny', 'tempfile' ); isa_ok( tempdir( TEMPLATE => 'tempXXXXXXX' ), 'Path::Tiny', 'tempdir' ); done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # vim: ts=4 sts=4 sw=4 et: ��subsumes.t��0000644��00000006242�15125143206�0006602 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use TestUtils qw/exception/; use Path::Tiny; use Cwd; my $IS_WIN32 = $^O eq 'MSWin32'; my @cases = ( # path1 => path2 => path1->subsumes(path2) "identity always subsumes" => [ [ '.' => '.' => 1 ], [ '/' => '/' => 1 ], [ '..' => '..' => 1 ], [ '../..' => '../..' => 1 ], [ '/foo/' => '/foo' => 1 ], [ 'foo/' => 'foo' => 1 ], [ './foo' => 'foo' => 1 ], [ 'foo/.' => 'foo' => 1 ], ], "absolute v. absolute" => [ [ '/foo' => '/foo/bar' => 1 ], [ '/foo' => '/foo/bar/baz' => 1 ], [ '/foo' => '/foo/bar/baz/' => 1 ], [ '/' => '/foo' => 1 ], [ '/foo' => '/bar' => 0 ], [ '/foo/bar' => '/foo/baz' => 0 ], ], "relative v. relative" => [ [ '.' => 'foo' => 1 ], [ 'foo' => 'foo/baz' => 1 ], [ './foo/bar' => 'foo/bar/baz' => 1 ], [ './foo/bar' => './foo/bar' => 1 ], [ './foo/bar' => 'foo/bar' => 1 ], [ 'foo/bar' => './foo/bar' => 1 ], [ 'foo/bar' => 'foo/baz' => 0 ], ], "relative v. absolute" => [ [ path(".")->absolute => 't' => 1 ], [ "." => path('t')->absolute => 1 ], [ "foo" => path('t')->absolute => 0 ], [ path("..")->realpath => 't' => 1 ], [ path("lib")->absolute => 't' => 0 ], ], "updirs in paths" => [ [ '/foo' => '/foo/bar/baz/..' => 1 ], [ '/foo/bar' => '/foo/bar/../baz' => $IS_WIN32 ? 0 : 1 ], [ '/foo/../bar' => '/bar' => $IS_WIN32 ? 1 : 0 ], [ '..' => '../bar' => 1 ], ], ); if ($IS_WIN32) { my $vol = path( Win32::GetCwd() )->volume . "/"; my $other = $vol ne 'Z:/' ? 'Z:/' : 'Y:/'; push @cases, 'Win32 cases', [ [ "C:/foo" => "C:/foo" => 1 ], [ "C:/foo" => "C:/bar" => 0 ], [ "C:/" => "C:/foo" => 1 ], [ "C:/" => "D:/" => 0 ], [ "${vol}foo" => "/foo" => 1 ], [ $vol => "/foo" => 1 ], [ $vol => $other => 0 ], [ "/" => $vol => 1 ], [ "/" => $other => 0 ], [ "/foo" => "${vol}foo" => 1 ], ]; } while (@cases) { my ( $subtest, $tests ) = splice( @cases, 0, 2 ); subtest $subtest => sub { for my $t (@$tests) { my ( $path1, $path2, $subsumes ) = @$t; my $label = join( " ", $path1, ( $subsumes ? "subsumes" : "does not subsume" ), $path2 ); ok( !!path($path1)->subsumes($path2) eq !!$subsumes, $label ) or diag "PATH 1:\n", explain( path($path1) ), "\nPATH2:\n", explain( path($path2) ); } }; } done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��mkdir.t��0000644��00000001760�15125143206�0006042 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use File::Temp (); use lib 't/lib'; use TestUtils qw/exception/; use Path::Tiny; my $tempdir = File::Temp->newdir; my $path = path($tempdir)->child("foo"); ok( !-e $path, "target directory not created yet" ); ok( $path->mkdir, "mkdir on directory returned true" ); ok( -d $path, "target directory created" ); ok( $path->mkdir, "mkdir on existing directory returned true" ); if ( $^O ne 'MSWin32' ) { my $path2 = path($tempdir)->child("bar"); ok( !-e $path2, "target directory not created yet" ); ok( $path2->mkdir( { mode => 0700 } ), "mkdir on directory with mode" ); if ( $^O ne 'msys' ) { is( $path2->stat->mode & 0777, 0700, "correct mode" ); } ok( -d $path2, "target directory created" ); } done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��basic.t��0000644��00000022101�15125143206�0006005 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use File::Spec; use File::Glob; use Path::Tiny; use Cwd; my $IS_WIN32 = $^O eq 'MSWin32'; my $IS_CYGWIN = $^O eq 'cygwin'; use lib 't/lib'; use TestUtils qw/exception/; my $file1 = path('foo.txt'); isa_ok( $file1, "Path::Tiny" ); ok $file1->isa('Path::Tiny'); is $file1, 'foo.txt'; ok $file1->is_relative; is $file1->dirname, '.'; is $file1->basename, 'foo.txt'; my $file2 = path( 'dir', 'bar.txt' ); is $file2, 'dir/bar.txt'; ok !$file2->is_absolute; is $file2->dirname, 'dir/'; is $file2->basename, 'bar.txt'; my $dir = path('tmp'); is $dir, 'tmp'; ok !$dir->is_absolute; is $dir->basename, 'tmp'; my $dir2 = path('/tmp'); is $dir2, '/tmp'; ok $dir2->is_absolute; my $cat = path( $dir, 'foo' ); is $cat, 'tmp/foo'; $cat = $dir->child('foo'); is $cat, 'tmp/foo'; is $cat->dirname, 'tmp/'; is $cat->basename, 'foo'; $cat = path( $dir2, 'foo' ); is $cat, '/tmp/foo'; $cat = $dir2->child('foo'); is $cat, '/tmp/foo'; isa_ok $cat, 'Path::Tiny'; is $cat->dirname, '/tmp/'; $cat = $dir2->child('foo'); is $cat, '/tmp/foo'; isa_ok $cat, 'Path::Tiny'; is $cat->basename, 'foo'; my $sib = $cat->sibling('bar'); is $sib, '/tmp/bar'; isa_ok $sib, 'Path::Tiny'; my $file = path('/foo//baz/./foo'); is $file, '/foo/baz/foo'; is $file->dirname, '/foo/baz/'; is $file->parent, '/foo/baz'; { my $file = path("foo/bar/baz"); is( $file->canonpath, File::Spec->canonpath("$file"), "canonpath" ); } { my $dir = path('/foo/bar/baz'); is $dir->parent, '/foo/bar'; is $dir->parent->parent, '/foo'; is $dir->parent->parent->parent, '/'; is $dir->parent->parent->parent->parent, '/'; $dir = path('foo/bar/baz'); is $dir->parent, 'foo/bar'; is $dir->parent->parent, 'foo'; is $dir->parent->parent->parent, '.'; is $dir->parent->parent->parent->parent, '..'; is $dir->parent->parent->parent->parent->parent, '../..'; } { my $dir = path("foo/"); is $dir, 'foo'; is $dir->parent, '.'; } { # Special cases for my $bad ( [''], [undef], [], [ '', 'var', 'tmp' ], [ 'foo', '', 'bar' ] ) { like( exception { path(@$bad) }, qr/positive-length/, "exception" ); } is( Path::Tiny->cwd, path( Cwd::getcwd() ) ); is( path('.')->absolute, path( Cwd::getcwd() ) ); } { my $file = path('/tmp/foo/bar.txt'); is $file->relative('/tmp'), 'foo/bar.txt'; is $file->relative('/tmp/foo'), 'bar.txt'; is $file->relative('/tmp/'), 'foo/bar.txt'; is $file->relative('/tmp/foo/'), 'bar.txt'; $file = path('one/two/three'); is $file->relative('one'), 'two/three'; $file = path('/one[0/two'); is $file->relative( '/one[0' ), 'two', 'path with regex special char'; } { my $file = Path::Tiny->new( File::Spec->rootdir ); my $root = Path::Tiny->rootdir; is( $file, $root, "rootdir is like path('/')" ); is( $file->child("lib"), "/lib", "child of rootdir is correct" ); } # constructor { is( path(qw/foo bar baz/), Path::Tiny->new(qw/foo bar baz/), "path() vs new" ); is( path(qw/foo bar baz/), path("foo/bar/baz"), "path(a,b,c) vs path('a/b/c')" ); } # tilde processing { # Construct expected paths manually with glob, but normalize with Path::Tiny # to work around windows slashes and drive case issues. Extract the interior # paths with ->[0] rather than relying on stringification, which will escape # leading tildes. my $homedir = path(glob('~'))->[0]; my $username = path($homedir)->basename; my $root_homedir = path(glob('~root'))->[0]; my $missing_homedir = path(glob('~idontthinkso'))->[0]; # remove one trailing slash from a path string, if present # so the result of concatenating a path that starts with a slash will be correct sub S ($) { ( my $p = $_[0] ) =~ s!/\z!!; $p } my @tests = ( # [arg for path(), expected string (undef if eq arg for path()), test string] ['~', $homedir, 'Test my homedir' ], ['~/', $homedir, 'Test my homedir with trailing "/"' ], ['~/foo/bar', S($homedir).'/foo/bar', 'Test my homedir with longer path' ], ['~/foo/bar/', S($homedir).'/foo/bar', 'Test my homedir, longer path and trailing "/"' ], ['~root', $root_homedir, 'Test root homedir' ], ['~root/', $root_homedir, 'Test root homedir with trailing /' ], ['~root/foo/bar', S($root_homedir).'/foo/bar', 'Test root homedir with longer path' ], ['~root/foo/bar/', S($root_homedir).'/foo/bar', 'Test root homedir, longer path and trailing "/"'], ['~idontthinkso', undef, 'Test homedir of nonexistant user' ], ['~idontthinkso', $missing_homedir, 'Test homedir of nonexistant user (via glob)' ], ['~blah blah', undef, 'Test space' ], ['~this is fun', undef, 'Test multiple spaces' ], ['~yikes \' apostrophe!', undef, 'Test spaces and embedded apostrophe' ], ['~hum " quote', undef, 'Test spaces and embedded quote' ], ['~hello ~there', undef, 'Test space-separated tildes' ], ["~fun\ttimes", undef, 'Test tab' ], ["~new\nline", undef, 'Test newline' ], ['~'.$username.' file', undef, 'Test \'~$username file\'' ], ['./~', '~', 'Test literal tilde under current directory' ], ['~idontthinkso[123]', undef, 'Test File::Glob metacharacter ['], ['~idontthinkso', undef, 'Test File::Glob metacharacter '], ['~idontthinkso?', undef, 'Test File::Glob metacharacter ?'], ['~idontthinkso{a}', undef, 'Test File::Glob metacharacter {'], ); if (! $IS_WIN32 && ! $IS_CYGWIN ) { push @tests, ['~idontthinkso\\x', undef, 'Test File::Glob metacharacter \\']; } for my $test (@tests) { my $path = path($test->[0]); my $internal_path = $path->[0]; # Avoid stringification adding a "./" prefix my $expected = defined $test->[1] ? $test->[1] : $test->[0]; is($internal_path, $expected, $test->[2]); is($path, $expected =~ /^~/ ? "./$expected" : $expected, '... and its stringification'); } is(path('.')->child('~')->[0], '~', 'Test indirect form of literal tilde under current directory'); is(path('.')->child('~'), './~', '... and its stringification'); $file = path('/tmp/foo/~root'); is $file->relative('/tmp/foo')->[0], '~root', 'relative path begins with tilde'; is $file->relative('/tmp/foo'), "./~root", '... and its stringification is escaped'; # successful tilde expansion of account names with glob metacharacters is # actually untested so far because it would require such accounts to exist # so instead we wrap File::Glob::bsd_glob to mock up certain responses: my %mock = ( '~i[dont]{think}so' => '/home/i[dont]{think}so', '~idont{think}so' => '/home/idont{think}so', '~i{dont,think}so' => '/home/i{dont,think}so', ); if ( ! $IS_WIN32 && ! $IS_CYGWIN ) { $mock{'~i?dontthinkso?'} = '/home/i?dontthinkso?'; } my $orig_bsd_glob = \&File::Glob::bsd_glob; my $do_brace_expansion_only = do { package File::Glob; GLOB_NOCHECK() \| GLOB_BRACE() \| GLOB_QUOTE() }; sub mock_bsd_glob { my $dequoted = $orig_bsd_glob->( $_[0], $do_brace_expansion_only ); $mock{ $dequoted } \|\| goto &$orig_bsd_glob; } no warnings 'redefine'; local File::Glob::bsd_glob = \&mock_bsd_glob; is(File::Glob::bsd_glob('{root}'), 'root', 'double-check of mock_bsd_glob dequoting'); is(File::Glob::bsd_glob('~root'), $root_homedir, 'double-check of mock_bsd_glob fallback'); for my $test (sort keys %mock) { is(path($test), $mock{ $test }, "tilde expansion with glob metacharacters in account name: $test"); } } # freeze/thaw { my @cases = qw( /foo/bar/baz" ./~root ); for my $c ( @cases ) { my $path = path($c); is( Path::Tiny->THAW( "fake", $path->FREEZE("fake") ), $path, "FREEZE-THAW roundtrip: $c" ); } } # assertions { my $err = exception { path("aljfakdlfadks")->assert( sub { $_->exists } ) }; like( $err, qr/failed assertion/, "assert exists" ); my $path; $err = exception { $path = path("t")->assert( sub { -d && -r _ } ) }; is( $err, '', "no exception if assertion succeeds" ); isa_ok( $path, "Path::Tiny", "assertion return value" ); $err = exception { path(".")->visit( sub { $_[1]->{$_} = { path => $_ } }, { recurse => 1 }, ); }; is $err, "", 'no exception'; } done_testing(); ��digest.t��0000644��00000002404�15125143206�0006207 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use TestUtils qw/exception/; use Path::Tiny; use Digest; use Digest::MD5; # for dependency detection my $dir = Path::Tiny->tempdir; my $file = $dir->child('foo.bin'); my $chunk = pack( "Z", "Hello Path::Tiny\nThis is packed binary string\n" ); ok( $file->spew_raw($chunk), "created test file with packed binary string" ); is( $file->digest, 'a98e605049836e8adb36d351abb95a09e9e5e200703576ecdaec0e697d17d626', 'digest SHA-256 (hardcoded)', ); my $sha = Digest->new('SHA-256'); $sha->add($chunk); my $sha_hex = $sha->hexdigest; is( $file->digest, $sha_hex, 'digest SHA-256' ); is( $file->digest( { chunk_size => 10 } ), $sha_hex, 'digest SHA-256 (chunked)' ); is( $file->digest('MD5'), 'ce05aca61c0e58d7396073b668bcafd0', 'digest MD5 (hardcoded)', ); my $md5 = Digest->new('MD5'); $md5->add($chunk); my $md5_hex = $md5->hexdigest; is( $file->digest('MD5'), $md5_hex, 'digest MD5', ); is( $file->digest( { chunk_size => 10 }, 'MD5' ), $md5_hex, 'digest MD5 (chunked)' ); done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��locking.t��0000644��00000002576�15125143206�0006370 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use File::Spec; use Cwd; use lib 't/lib'; use TestUtils qw/exception/; use Fcntl ':flock'; use Path::Tiny; { # is temp partition lockable? my $file = Path::Tiny->tempfile; open my $fh, ">>", $file; flock $fh, LOCK_EX or plan skip_all => "Can't lock tempfiles on this OS/filesystem"; } # Guard against external environment local $ENV{PERL_PATH_TINY_NO_FLOCK} = 0; subtest 'write locks blocks read lock' => sub { my $rc = check_flock(); is( $rc >> 8, 0, "subprocess failed to get lock" ); }; subtest 'flock ignored if PERL_PATH_TINY_NO_FLOCK=1' => sub { local $ENV{PERL_PATH_TINY_NO_FLOCK} = 1; my $rc = check_flock(); is( $rc >> 8, 1, "subprocess managed to get lock" ); }; sub check_flock { my $file = Path::Tiny->tempfile; ok $file, "Got a tempfile"; my $fh = $file->openw( { locked => 1 } ); ok $fh, "Opened file for writing with lock"; $fh->autoflush(1); print {$fh} "hello"; # check if a different process can get a lock; use RW mode for AIX my $locktester = Path::Tiny->tempfile; $locktester->spew(<<"HERE"); use strict; use warnings; use Fcntl ':flock'; open my \$fh, "+<", "$file"; exit flock( \$fh, LOCK_SH\|LOCK_NB ); HERE my $rc = system( $^X, $locktester ); isnt( $rc, -1, "ran process to try to get lock" ); return $rc; } done_testing; ��input_output.t��0000644��00000044502�15125143206�0007514 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use TestUtils qw/exception/; use Path::Tiny; my $tmp = Path::Tiny->tempdir; sub _lines { return ( "Line1\r\n", "Line2\n" ); } sub _utf8_lines { my $line3 = "\302\261\n"; utf8::decode($line3); return ( _lines(), $line3 ); } sub _no_end_of_newline_lines { return ( _lines(), "No end of newline" ); } sub _utf8_no_end_of_newline_lines { return ( _utf8_lines(), "No end of newline" ); } subtest "spew -> slurp" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew(_lines), "spew" ); is( $file->slurp, join( '', _lines ), "slurp" ); }; subtest "spew -> slurp (empty)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew, "spew" ); is( $file->slurp, '', "slurp" ); }; subtest "spew -> slurp (arrayref)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew( [_lines] ), "spew" ); is( $file->slurp, join( '', _lines ), "slurp" ); }; subtest "spew -> slurp (binmode)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew( { binmode => ":utf8" }, _utf8_lines ), "spew" ); is( $file->slurp( { binmode => ":utf8" } ), join( '', _utf8_lines ), "slurp" ); }; subtest "spew -> slurp (open hint)" => sub { plan skip_all => "Needs 5.10" unless $] >= 5.010; use open IO => ":utf8"; my $file = Path::Tiny->tempfile; ok( $file->spew(_utf8_lines), "spew" ); my $got = $file->slurp(); is( $got, join( '', _utf8_lines ), "slurp" ); ok( utf8::is_utf8($got), "is UTF8" ); }; subtest "spew -> slurp (UTF-8)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew_utf8(_utf8_lines), "spew" ); my $got = $file->slurp_utf8(); is( $got, join( '', _utf8_lines ), "slurp" ); ok( utf8::is_utf8($got), "is UTF8" ); }; subtest "spew -> slurp (UTF-8, arrayref)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew_utf8( [_utf8_lines] ), "spew" ); my $got = $file->slurp_utf8(); is( $got, join( '', _utf8_lines ), "slurp" ); ok( utf8::is_utf8($got), "is UTF8" ); }; subtest "spew -> slurp (raw)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew_raw(_lines), "spew" ); is( $file->slurp_raw, join( '', _lines ), "slurp" ); }; subtest "spew -> lines" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew(_lines), "spew" ); is( join( '', $file->lines ), join( '', _lines ), "lines" ); is( scalar $file->lines, my $cnt =()= _lines, "lines (scalar)" ); }; subtest "spew -> lines (open hint)" => sub { plan skip_all => "Needs 5.10" unless $] >= 5.010; use open IO => ":utf8"; my $file = Path::Tiny->tempfile; ok( $file->spew(_utf8_lines), "spew" ); my $got = join( '', $file->lines() ); is( $got, join( '', _utf8_lines ), "slurp" ); ok( utf8::is_utf8($got), "is UTF8" ); }; subtest "spew -> lines (UTF-8)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew_utf8(_utf8_lines), "spew" ); my $got = join( '', $file->lines_utf8() ); is( $got, join( '', _utf8_lines ), "slurp" ); ok( utf8::is_utf8($got), "is UTF8" ); is( scalar $file->lines, my $cnt =()= _utf8_lines, "lines (scalar)" ); }; subtest "spew -> lines (raw)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew_raw(_lines), "spew" ); is( join( '', $file->lines_raw ), join( '', _lines ), "lines" ); }; subtest "spew -> lines (count)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew(_lines), "spew" ); my @exp = _lines; is( join( '', $file->lines( { count => 2 } ) ), join( '', @exp[ 0 .. 1 ] ), "lines" ); is( join( '', $file->lines( { count => -2 } ) ), join( '', @exp[ 0 .. 1 ] ), "lines" ); }; subtest "spew -> lines (count, less than)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew(_lines), "spew" ); my @exp = _lines; is( join( '', $file->lines( { count => 1 } ) ), $exp[0], "lines" ); is( join( '', $file->lines( { count => -1 } ) ), $exp[1], "lines" ); }; subtest "spew -> lines (count, more than)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew(_lines), "spew" ); my @exp = _lines; is( join( '\|', $file->lines( { count => 3 } ) ), join( "\|", @exp ), "lines" ); is( join( '\|', $file->lines( { count => -3 } ) ), join( "\|", @exp ), "lines" ); }; subtest "spew -> lines (count, chomp)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew(_lines), "spew" ); my @exp = map { s/[\r\n]+//; $_ } _lines; is( join( '', $file->lines( { chomp => 1, count => 2 } ) ), join( '', @exp[ 0 .. 1 ] ), "lines" ); is( join( '', $file->lines( { chomp => 1, count => -2 } ) ), join( '', @exp[ 0 .. 1 ] ), "lines" ); }; subtest "spew -> lines (count, no end of newline)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew(_no_end_of_newline_lines), "spew" ); my @exp = _no_end_of_newline_lines; is( join( '', $file->lines( { count => 3 } ) ), join( '', @exp[ 0 .. 2 ] ), "lines" ); is( join( '', $file->lines( { count => -3 } ) ), join( '', @exp[ 0 .. 2 ] ), "lines" ); }; subtest "spew -> lines (count, less than, no end of newline)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew(_no_end_of_newline_lines), "spew" ); my @exp = _no_end_of_newline_lines; is( join( '', $file->lines( { count => 1 } ) ), $exp[0], "lines" ); is( join( '', $file->lines( { count => -1 } ) ), $exp[2], "lines" ); }; subtest "spew -> lines (count, more than, no end of newline)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew(_no_end_of_newline_lines), "spew" ); my @exp = _no_end_of_newline_lines; is( join( '\|', $file->lines( { count => 4 } ) ), join( "\|", @exp ), "lines" ); is( join( '\|', $file->lines( { count => -4 } ) ), join( "\|", @exp ), "lines" ); }; subtest "spew -> lines (count, chomp, no end of newline)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew(_no_end_of_newline_lines), "spew" ); my @exp = map { s/[\r\n]+//; $_ } _no_end_of_newline_lines; is( join( '', $file->lines( { chomp => 1, count => 3 } ) ), join( '', @exp[ 0 .. 2 ] ), "lines" ); is( join( '', $file->lines( { chomp => 1, count => -3 } ) ), join( '', @exp[ 0 .. 2 ] ), "lines" ); }; subtest "spew -> lines (count, UTF-8)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew_utf8(_utf8_lines), "spew" ); my @exp = _utf8_lines; is( join( '', $file->lines_utf8( { count => 3 } ) ), join( '', @exp ), "lines" ); is( join( '', $file->lines_utf8( { count => -3 } ) ), join( '', @exp ), "lines" ); }; subtest "spew -> lines (count, chomp, UTF-8)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew_utf8(_utf8_lines), "spew" ); my @exp = map { s/[\r\n]+//; $_ } _utf8_lines; is( join( '', $file->lines_utf8( { chomp => 1, count => 2 } ) ), join( '', @exp[ 0 .. 1 ] ), "lines" ); is( join( '', $file->lines_utf8( { chomp => 1, count => -2 } ) ), join( '', @exp[ 1 .. 2 ] ), "lines" ); }; subtest "spew -> lines (chomp, only newlines)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew( "\n" x 5 ), "spew" ); my @exp = ('') x 5; is( join( '\|', $file->lines_utf8( { chomp => 1 } ) ), join( '\|', @exp ), "lines" ); }; subtest "spew -> lines (chomp, UTF-8)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew_utf8(_utf8_lines), "spew" ); my @exp = map { s/[\r\n]+//; $_ } _utf8_lines; is( join( '', $file->lines_utf8( { chomp => 1 } ) ), join( '', @exp ), "lines" ); }; subtest "spew -> lines (count, UTF-8, no end of newline)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew_utf8(_utf8_no_end_of_newline_lines), "spew" ); my @exp = _utf8_no_end_of_newline_lines; is( join( '', $file->lines_utf8( { count => 4 } ) ), join( '', @exp ), "lines" ); is( join( '', $file->lines_utf8( { count => -4 } ) ), join( '', @exp ), "lines" ); }; subtest "spew -> lines (count, chomp, UTF-8, no end of newline)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew_utf8(_utf8_no_end_of_newline_lines), "spew" ); my @exp = map { s/[\r\n]+//; $_ } _utf8_no_end_of_newline_lines; is( join( '', $file->lines_utf8( { chomp => 1, count => 2 } ) ), join( '', @exp[ 0 .. 1 ] ), "lines" ); is( join( '', $file->lines_utf8( { chomp => 1, count => -2 } ) ), join( '', @exp[ 2 .. 3 ] ), "lines" ); }; subtest "spew -> lines (count, raw)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew_raw(_lines), "spew" ); my @exp = _lines; is( join( '', $file->lines_raw( { count => 2 } ) ), join( '', @exp ), "lines" ); is( join( '', $file->lines_raw( { count => -2 } ) ), join( '', @exp ), "lines" ); }; subtest "spew -> lines (count, raw, no end of newline)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew_raw(_no_end_of_newline_lines), "spew" ); my @exp = _no_end_of_newline_lines; is( join( '', $file->lines_raw( { count => 3 } ) ), join( '', @exp ), "lines" ); is( join( '', $file->lines_raw( { count => -3 } ) ), join( '', @exp ), "lines" ); }; subtest "append -> slurp" => sub { my $file = Path::Tiny->tempfile; ok( $file->append(_lines), "append" ); is( $file->slurp, join( '', _lines ), "slurp" ); }; subtest "append -> slurp (empty)" => sub { my $file = Path::Tiny->tempfile; ok( $file->append, "append" ); is( $file->slurp, "", "slurp" ); }; subtest "append -> slurp (arrayref)" => sub { my $file = Path::Tiny->tempfile; ok( $file->append( [_lines] ), "append" ); is( $file->slurp, join( '', _lines ), "slurp" ); }; subtest "append -> slurp (piecemeal)" => sub { my $file = Path::Tiny->tempfile; ok( $file->append($_), "piecemeal append" ) for _lines; is( $file->slurp, join( '', _lines ), "slurp" ); }; subtest "append -> slurp (binmode)" => sub { my $file = Path::Tiny->tempfile; ok( $file->append( { binmode => ":utf8" }, _utf8_lines ), "append" ); is( $file->slurp( { binmode => ":utf8" } ), join( '', _utf8_lines ), "slurp" ); }; subtest "append -> slurp (truncate)" => sub { my $file = Path::Tiny->tempfile; ok( $file->append(_lines), "append" ); is( $file->slurp, join( '', _lines ), "slurp" ); ok( $file->append( { truncate => 1 }, _lines ), "append with truncate" ); is( $file->slurp, join( '', _lines ), "slurp" ); }; subtest "append -> slurp (open hint)" => sub { plan skip_all => "Needs 5.10" unless $] >= 5.010; use open IO => ':utf8'; my $file = Path::Tiny->tempfile; ok( $file->append(_utf8_lines), "append" ); is( $file->slurp, join( '', _utf8_lines ), "slurp" ); }; subtest "append -> slurp (UTF-8)" => sub { my $file = Path::Tiny->tempfile; ok( $file->append_utf8(_utf8_lines), "append" ); is( $file->slurp_utf8, join( '', _utf8_lines ), "slurp" ); }; subtest "append -> slurp (truncate, UTF8)" => sub { my $file = Path::Tiny->tempfile; ok( $file->append_utf8(_utf8_lines), "append" ); is( $file->slurp_utf8, join( '', _utf8_lines ), "slurp" ); ok( $file->append_utf8( { truncate => 1 }, _utf8_lines ), "append with truncate" ); is( $file->slurp_utf8, join( '', _utf8_lines ), "slurp" ); }; subtest "append -> slurp (raw)" => sub { my $file = Path::Tiny->tempfile; ok( $file->append_raw(_lines), "append" ); is( $file->slurp_raw, join( '', _lines ), "slurp" ); }; subtest "append -> slurp (truncate, raw)" => sub { my $file = Path::Tiny->tempfile; ok( $file->append_raw(_lines), "append" ); is( $file->slurp_raw, join( '', _lines ), "slurp" ); ok( $file->append_raw( { truncate => 1 }, _lines ), "append with truncate" ); is( $file->slurp_raw, join( '', _lines ), "slurp" ); }; subtest "openw -> openr" => sub { my $file = Path::Tiny->tempfile; { my $fh = $file->openw; ok( ( print {$fh} _lines ), "openw & print" ); } { my $fh = $file->openr; my $got = do { local $/, <$fh> }; is( $got, join( '', _lines ), "openr & read" ); } }; subtest "openw -> openr (open hint)" => sub { plan skip_all => "Needs 5.10" unless $] >= 5.010; use open IO => ':utf8'; my $file = Path::Tiny->tempfile; { my $fh = $file->openw; ok( ( print {$fh} _utf8_lines ), "openw & print" ); } { my $fh = $file->openr; my $got = do { local $/, <$fh> }; is( $got, join( '', _utf8_lines ), "openr & read" ); ok( utf8::is_utf8($got), "is UTF8" ); } }; subtest "openw -> openr (UTF-8)" => sub { my $file = Path::Tiny->tempfile; { my $fh = $file->openw_utf8; ok( ( print {$fh} _utf8_lines ), "openw & print" ); } { my $fh = $file->openr_utf8; my $got = do { local $/, <$fh> }; is( $got, join( '', _utf8_lines ), "openr & read" ); ok( utf8::is_utf8($got), "is UTF8" ); } }; subtest "openw -> openr (raw)" => sub { my $file = Path::Tiny->tempfile; { my $fh = $file->openw_raw; ok( ( print {$fh} _lines ), "openw & print" ); } { my $fh = $file->openr_raw; my $got = do { local $/, <$fh> }; is( $got, join( '', _lines ), "openr & read" ); } }; subtest "opena -> openr" => sub { my $file = Path::Tiny->tempfile; my @lines = _lines; { my $fh = $file->openw; ok( ( print {$fh} shift @lines ), "openw & print one line" ); } { my $fh = $file->opena; ok( ( print {$fh} @lines ), "opena & print rest of lines" ); } { my $fh = $file->openr; my $got = do { local $/, <$fh> }; is( $got, join( '', _lines ), "openr & read" ); } }; subtest "opena -> openr (open hint)" => sub { plan skip_all => "Needs 5.10" unless $] >= 5.010; use open IO => ':utf8'; my $file = Path::Tiny->tempfile; my @lines = _utf8_lines; { my $fh = $file->openw; ok( ( print {$fh} shift @lines ), "openw & print one line" ); } { my $fh = $file->opena; ok( ( print {$fh} @lines ), "opena & print rest of lines" ); } { my $fh = $file->openr; my $got = do { local $/, <$fh> }; is( $got, join( '', _utf8_lines ), "openr & read" ); ok( utf8::is_utf8($got), "is UTF8" ); } }; subtest "opena -> openr (UTF-8)" => sub { my $file = Path::Tiny->tempfile; my @lines = _utf8_lines; { my $fh = $file->openw_utf8; ok( ( print {$fh} shift @lines ), "openw & print one line" ); } { my $fh = $file->opena_utf8; ok( ( print {$fh} @lines ), "opena & print rest of lines" ); } { my $fh = $file->openr_utf8; my $got = do { local $/, <$fh> }; is( $got, join( '', _utf8_lines ), "openr & read" ); ok( utf8::is_utf8($got), "is UTF8" ); } }; subtest "opena -> openr (raw)" => sub { my $file = Path::Tiny->tempfile; my @lines = _lines; { my $fh = $file->openw_raw; ok( ( print {$fh} shift @lines ), "openw & print one line" ); } { my $fh = $file->opena_raw; ok( ( print {$fh} @lines ), "opena & print rest of lines" ); } { my $fh = $file->openr_raw; my $got = do { local $/, <$fh> }; is( $got, join( '', _lines ), "openr & read" ); } }; subtest "openrw" => sub { my $file = Path::Tiny->tempfile; my $fh = $file->openrw; ok( ( print {$fh} _lines ), "openrw & print" ); ok( seek( $fh, 0, 0 ), "seek back to start" ); my $got = do { local $/, <$fh> }; is( $got, join( '', _lines ), "openr & read" ); }; subtest "openrw (open hint)" => sub { plan skip_all => "Needs 5.10" unless $] >= 5.010; use open IO => ':utf8'; my $file = Path::Tiny->tempfile; my $fh = $file->openrw; ok( ( print {$fh} _utf8_lines ), "openrw & print" ); ok( seek( $fh, 0, 0 ), "seek back to start" ); my $got = do { local $/, <$fh> }; is( $got, join( '', _utf8_lines ), "openr & read" ); ok( utf8::is_utf8($got), "is UTF8" ); }; subtest "openrw (UTF-8)" => sub { my $file = Path::Tiny->tempfile; my $fh = $file->openrw_utf8; ok( ( print {$fh} _utf8_lines ), "openrw & print" ); ok( seek( $fh, 0, 0 ), "seek back to start" ); my $got = do { local $/, <$fh> }; is( $got, join( '', _utf8_lines ), "openr & read" ); ok( utf8::is_utf8($got), "is UTF8" ); }; subtest "openrw (raw)" => sub { my $file = Path::Tiny->tempfile; my $fh = $file->openrw_raw; ok( ( print {$fh} _lines ), "openrw & print" ); ok( seek( $fh, 0, 0 ), "seek back to start" ); my $got = do { local $/, <$fh> }; is( $got, join( '', _lines ), "openr & read" ); }; subtest "edit_utf8" => sub { my $file = Path::Tiny->tempfile; $file->spew_utf8(_utf8_lines); $file->edit_utf8( sub { s/^Line/Row/gm; } ); my $line3 = "\302\261\n"; utf8::decode($line3); is( $file->slurp_utf8, ("Row1\r\nRow2\n$line3"), "edit_utf8", ); }; subtest "edit_raw" => sub { my $file = Path::Tiny->tempfile; $file->spew_raw("Foo Bar\nClam Bar\n"); $file->edit_raw( sub { s/Bar/Mangle/; } ); is( $file->slurp_raw, "Foo Mangle\nClam Bar\n", "edit_raw", ); }; subtest "edit" => sub { my $file = Path::Tiny->tempfile; $file->spew_raw("One line\nTwo lines\nThree lines\n"); $file->edit( sub { s/line/row/; }, { binmode => ':raw' }, ); is( $file->slurp_raw, "One row\nTwo lines\nThree lines\n", "edit() was successful.", ); }; subtest "edit_lines_utf8" => sub { my $file = Path::Tiny->tempfile; $file->spew_utf8("Foo\nBar\nBaz\nQuux\n"); $file->edit_lines_utf8( sub { s/\A/prefix = /gm; } ); is( $file->slurp_utf8, ("prefix = Foo\nprefix = Bar\nprefix = Baz\nprefix = Quux\n"), "edit_lines_utf8", ); }; subtest "edit_lines_raw" => sub { my $file = Path::Tiny->tempfile; $file->spew_raw("Foo\nBar\nBaz\nQuux\n"); $file->edit_lines_raw( sub { s/\A/prefix = /gm; } ); is( $file->slurp_raw, ("prefix = Foo\nprefix = Bar\nprefix = Baz\nprefix = Quux\n"), "edit_lines_utf8", ); }; subtest "edit_lines" => sub { my $file = Path::Tiny->tempfile; $file->spew_raw("Foo\nBar\nBaz\nQuux\n"); $file->edit_lines( sub { s/a/[replacement]/; }, { binmode => ':raw' } ); is( $file->slurp_raw, ("Foo\nB[replacement]r\nB[replacement]z\nQuux\n"), "edit_lines", ); }; done_testing; 1; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��sig_die.t��0000644��00000001336�15125143206�0006336 0��ustar�00��#!./perl # # Copyright (c) 2002 Slaven Rezic # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use strict; use Test::More tests => 1; my @warns; $SIG{__WARN__} = sub { push @warns, shift }; $SIG{__DIE__} = sub { require Carp; warn Carp::longmess(); warn "Evil die!" }; require Storable; Storable::dclone({foo => "bar"}); is(join("", @warns), "", "__DIE__ is not evil here"); ��input_output_no_UU.t��0000644��00000001066�15125143206�0010617 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; # Tiny equivalent of Devel::Hide # Tiny equivalent of Devel::Hide use lib map { my ( $m, $c ) = ( $_, qq{die "Can't locate $_ (hidden)\n"} ); sub { return unless $_[1] eq $m; open my $fh, "<", \$c; return $fh } } qw{Unicode/UTF8.pm}; note "Hiding Unicode::UTF8"; do "./t/input_output.t" or die $@ \|\| $!; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��children.t��0000644��00000002372�15125143206�0006524 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use File::Basename (); use File::Temp (); use File::Spec::Unix; use lib 't/lib'; use TestUtils qw/exception/; use Path::Tiny; my $tempdir = File::Temp->newdir; my @kids = qw/apple banana carrot/; path($tempdir)->child($_)->touch for @kids; my @expected = map { path( File::Spec::Unix->catfile( $tempdir, $_ ) ) } @kids; is_deeply( [ sort { $a cmp $b } path($tempdir)->children ], [ sort @expected ], "children correct" ); my $regexp = qr/.a/; is_deeply( [ sort { $a cmp $b } path($tempdir)->children($regexp) ], [ sort grep { my $child = File::Basename::basename($_); $child =~ /$regexp/ } @expected ], "children correct with Regexp argument" ); my $arrayref = []; eval { path($tempdir)->children($arrayref) }; like $@, qr/Invalid argument '\Q$arrayref\E' for children()/, 'children with invalid argument'; my $raw_tilde = path(".", "~"); my $tilde_child = $raw_tilde->child("rhubarb"); is( $tilde_child, "./~/rhubarb", "child of literal tilde" ); done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��00-report-prereqs.dd��0000644��00000007320�15125143206�0010265 0��ustar�00��do { my $x = { 'configure' => { 'requires' => { 'ExtUtils::MakeMaker' => '0' }, 'suggests' => { 'JSON::PP' => '2.27300' } }, 'develop' => { 'recommends' => { 'Business::ISBN' => '3.005', 'Dist::Zilla::PluginBundle::Git::VersionManager' => '0.007', 'Storable' => '0' }, 'requires' => { 'File::Spec' => '0', 'IO::Handle' => '0', 'IPC::Open3' => '0', 'Pod::Coverage::TrustPod' => '0', 'Test::CPAN::Meta' => '0', 'Test::DependentModules' => '0.27', 'Test::MinimumVersion' => '0', 'Test::Mojibake' => '0', 'Test::More' => '0.94', 'Test::Pod' => '1.41', 'Test::Pod::Coverage' => '1.08', 'Test::Portability::Files' => '0', 'Test::Spelling' => '0.12', 'Test::Version' => '1' } }, 'runtime' => { 'requires' => { 'Carp' => '0', 'Cwd' => '0', 'Data::Dumper' => '0', 'Encode' => '0', 'Exporter' => '5.57', 'MIME::Base32' => '0', 'MIME::Base64' => '2', 'Net::Domain' => '0', 'Scalar::Util' => '0', 'constant' => '0', 'integer' => '0', 'overload' => '0', 'parent' => '0', 'perl' => '5.008001', 'strict' => '0', 'utf8' => '0', 'warnings' => '0' }, 'suggests' => { 'Business::ISBN' => '3.005', 'Regexp::IPv6' => '0.03' } }, 'test' => { 'recommends' => { 'CPAN::Meta' => '2.120900' }, 'requires' => { 'ExtUtils::MakeMaker' => '0', 'File::Spec' => '0', 'File::Spec::Functions' => '0', 'File::Temp' => '0', 'Test::Fatal' => '0', 'Test::More' => '0.96', 'Test::Needs' => '0', 'Test::Warnings' => '0', 'utf8' => '0' } } }; $x; }��00-report-prereqs.t��0000644��00000013601�15125143206�0010140 0��ustar�00��#!perl use strict; use warnings; # This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.029 use Test::More tests => 1; use ExtUtils::MakeMaker; use File::Spec; # from $version::LAX my $lax_version_re = qr/(?: undef \| (?: (?:[0-9]+) (?: \. \| (?:\.[0-9]+) (?:_[0-9]+)? )? \| (?:\.[0-9]+) (?:_[0-9]+)? ) \| (?: v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? \| (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? ) )/x; # hide optional CPAN::Meta modules from prereq scanner # and check if they are available my $cpan_meta = "CPAN::Meta"; my $cpan_meta_pre = "CPAN::Meta::Prereqs"; my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic # Verify requirements? my $DO_VERIFY_PREREQS = 1; sub _max { my $max = shift; $max = ( $_ > $max ) ? $_ : $max for @_; return $max; } sub _merge_prereqs { my ($collector, $prereqs) = @_; # CPAN::Meta::Prereqs object if (ref $collector eq $cpan_meta_pre) { return $collector->with_merged_prereqs( CPAN::Meta::Prereqs->new( $prereqs ) ); } # Raw hashrefs for my $phase ( keys %$prereqs ) { for my $type ( keys %{ $prereqs->{$phase} } ) { for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; } } } return $collector; } my @include = qw( ); my @exclude = qw( ); # Add static prereqs to the included modules list my $static_prereqs = do './t/00-report-prereqs.dd'; # Merge all prereqs (either with ::Prereqs or a hashref) my $full_prereqs = _merge_prereqs( ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), $static_prereqs ); # Add dynamic prereqs to the included modules list (if we can) my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; my $cpan_meta_error; if ( $source && $HAS_CPAN_META && (my $meta = eval { CPAN::Meta->load_file($source) } ) ) { $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); } else { $cpan_meta_error = $@; # capture error from CPAN::Meta->load_file($source) $source = 'static metadata'; } my @full_reports; my @dep_errors; my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; # Add static includes into a fake section for my $mod (@include) { $req_hash->{other}{modules}{$mod} = 0; } for my $phase ( qw(configure build test runtime develop other) ) { next unless $req_hash->{$phase}; next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); for my $type ( qw(requires recommends suggests conflicts modules) ) { next unless $req_hash->{$phase}{$type}; my $title = ucfirst($phase).' '.ucfirst($type); my @reports = [qw/Module Want Have/]; for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { next if grep { $_ eq $mod } @exclude; my $want = $req_hash->{$phase}{$type}{$mod}; $want = "undef" unless defined $want; $want = "any" if !$want && $want == 0; if ($mod eq 'perl') { push @reports, ['perl', $want, $]]; next; } my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; my $file = $mod; $file =~ s{::}{/}g; $file .= ".pm"; my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; if ($prefix) { my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); $have = "undef" unless defined $have; push @reports, [$mod, $want, $have]; if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { if ( $have !~ /\A$lax_version_re\z/ ) { push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; } elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { push @dep_errors, "$mod version '$have' is not in required range '$want'"; } } } else { push @reports, [$mod, $want, "missing"]; if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { push @dep_errors, "$mod is not installed ($req_string)"; } } } if ( @reports ) { push @full_reports, "=== $title ===\n\n"; my $ml = _max( map { length $_->[0] } @reports ); my $wl = _max( map { length $_->[1] } @reports ); my $hl = _max( map { length $_->[2] } @reports ); if ($type eq 'modules') { splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; push @full_reports, map { sprintf(" %s %s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; } else { splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; push @full_reports, map { sprintf(" %s %s %s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; } push @full_reports, "\n"; } } } if ( @full_reports ) { diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; } if ( $cpan_meta_error \|\| @dep_errors ) { diag "\n* WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING \n"; } if ( $cpan_meta_error ) { my ($orig_source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; diag "\nCPAN::Meta->load_file('$orig_source') failed with: $cpan_meta_error\n"; } if ( @dep_errors ) { diag join("\n", "\nThe following REQUIRED prerequisites were not satisfied:\n", @dep_errors, "\n" ); } pass('Reported prereqs'); # vim: ts=4 sts=4 sw=4 et: ��size.t��0000644��00000011415�15125143206�0005704 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use TestUtils qw/exception tempd/; use Path::Tiny; subtest "size API tests" => sub { my $wd = tempd(); my $path = path("1025"); $path->spew( "A" x 1025 ); is( $path->size, -s $path, "size() is -s" ); is( $path->size_human, "1.1 K", "size_human() is 1.1 K" ); }; subtest "size_human format" => sub { my $wd = tempd(); my $base2 = path("1024"); $base2->spew( "A" x 1024 ); my $base10 = path("1000"); $base10->spew( "A" x 1000 ); is( $base2->size_human, "1.0 K", "default" ); is( $base2->size_human( { format => "ls" } ), "1.0 K", "explicit ls" ); is( $base2->size_human( { format => "iec" } ), "1.0 KiB", "iec" ); is( $base10->size_human( { format => "si" } ), "1.0 kB", "si" ); is( path("doesnotexist")->size_human, "", "missing file" ); like( exception { $base2->size_human( { format => "fake" } ) }, qr/Invalid format 'fake'/, "bad format exception" ); }; # The rest of the tests use the private function for size conversion # rather than actually creating files of each size. Test cases were # derived from actual `ls -lh` output on Ubuntu 20.04. my $kib = 1024; my %ls_tests = ( 0 => "0", $kib - 1 => "1023", $kib => "1.0 K", $kib + 1 => "1.1 K", int( 1.1 $kib ) => "1.1 K", int( 1.1 * $kib ) + 1 => "1.2 K", int( 1.9 * $kib ) => "1.9 K", int( 1.9 * $kib ) + 1 => "2.0 K", 9 * $kib => "9.0 K", 9 * $kib + 1 => "9.1 K", int( 9.9 * $kib ) => "9.9 K", int( 9.9 * $kib ) + 1 => "10 K", 10 * $kib => "10 K", 10 * $kib + 1 => "11 K", ( $kib - 1 ) * $kib => "1023 K", ( $kib - 1 ) * $kib + 1 => "1.0 M", $kib2 - 1 => "1.0 M", $kib2 => "1.0 M", $kib*2 + 1 => "1.1 M", int( 1.1 $kib*2 ) => "1.1 M", int( 1.1 $kib*2 ) + 1 => "1.2 M", int( 1.9 $kib*2 ) => "1.9 M", int( 1.9 $kib*2 ) + 1 => "2.0 M", 9 $kib*2 => "9.0 M", 9 $kib*2 + 1 => "9.1 M", int( 9.9 $kib*2 ) => "9.9 M", int( 9.9 $kib*2 ) + 1 => "10 M", 10 $kib*2 => "10 M", 10 $kib*2 + 1 => "11 M", ( $kib - 1 ) $kib*2 => "1023 M", ( $kib - 1 ) $kib*2 + 1 => "1.0 G", ); subtest "ls format" => sub { for my $k ( sort { $a <=> $b } keys %ls_tests ) { my $opts = Path::Tiny::_formats("ls"); my $got = Path::Tiny::_human_size( $k, @$opts ); is( $got, $ls_tests{$k}, "ls: $k" ); } }; subtest "iec format" => sub { for my $k ( sort { $a <=> $b } keys %ls_tests ) { my $opts = Path::Tiny::_formats("iec"); my $got = Path::Tiny::_human_size( $k, @$opts ); my $want = $ls_tests{$k}; $want .= "iB" if $want =~ /[a-z]/i; is( $got, $want, "iec: $k" ); } }; my $kb = 1000; my %si_tests = ( 0 => "0", $kb - 1 => "999", $kb => "1.0 kB", $kb + 1 => "1.1 kB", int( 1.1 $kb ) => "1.1 kB", int( 1.1 * $kb ) + 1 => "1.2 kB", int( 1.9 * $kb ) => "1.9 kB", int( 1.9 * $kb ) + 1 => "2.0 kB", 9 * $kb => "9.0 kB", 9 * $kb + 1 => "9.1 kB", int( 9.9 * $kb ) => "9.9 kB", int( 9.9 * $kb ) + 1 => "10 kB", 10 * $kb => "10 kB", 10 * $kb + 1 => "11 kB", ( $kb - 1 ) * $kb => "999 kB", ( $kb - 1 ) * $kb + 1 => "1.0 MB", $kb2 - 1 => "1.0 MB", $kb2 => "1.0 MB", $kb*2 + 1 => "1.1 MB", int( 1.1 $kb*2 ) => "1.1 MB", int( 1.1 $kb*2 ) + 1 => "1.2 MB", int( 1.9 $kb*2 ) => "1.9 MB", int( 1.9 $kb*2 ) + 1 => "2.0 MB", 9 $kb*2 => "9.0 MB", 9 $kb*2 + 1 => "9.1 MB", int( 9.9 $kb*2 ) => "9.9 MB", int( 9.9 $kb*2 ) + 1 => "10 MB", 10 $kb*2 => "10 MB", 10 $kb*2 + 1 => "11 MB", ( $kb - 1 ) $kb*2 => "999 MB", ( $kb - 1 ) $kb*2 + 1 => "1.0 GB", ); subtest "si format" => sub { for my $k ( sort { $a <=> $b } keys %si_tests ) { my $opts = Path::Tiny::_formats("si"); my $got = Path::Tiny::_human_size( $k, @$opts ); is( $got, $si_tests{$k}, "si: $k" ); } }; done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��zzz-spec.t��0000644��00000015174�15125143206�0006525 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use TestUtils qw/exception/; use Path::Tiny; use Cwd; my $IS_WIN32 = $^O eq 'MSWin32'; # tests adapted from File::Spec's t/Spec.t test # Each element in this array is a single test. Storing them this way makes # maintenance easy, and should be OK since perl should be pretty functional # before these tests are run. # the third column has Win32 specific alternative output; this appears to be # collapsing of foo/../bar type structures since Win32 has no symlinks and # doesn't need to keep the '..' part. -- xdg, 2013-01-30 my @tests = ( # [ Function , Expected , Win32-different ] [ "path('a','b','c')", 'a/b/c' ], [ "path('a','b','./c')", 'a/b/c' ], [ "path('./a','b','c')", 'a/b/c' ], [ "path('c')", 'c' ], [ "path('./c')", 'c' ], [ "path('/')", '/' ], [ "path('d1','d2','d3')", 'd1/d2/d3' ], [ "path('/','d2/d3')", '/d2/d3' ], [ "path('/.')", '/' ], [ "path('/./')", '/' ], [ "path('/a/./')", '/a' ], [ "path('/a/.')", '/a' ], [ "path('/../../')", '/' ], [ "path('/../..')", '/' ], [ "path('/t1/t2/t4')->relative('/t1/t2/t3')", '../t4' ], [ "path('/t1/t2')->relative('/t1/t2/t3')", '..' ], [ "path('/t1/t2/t3/t4')->relative('/t1/t2/t3')", 't4' ], [ "path('/t4/t5/t6')->relative('/t1/t2/t3')", '../../../t4/t5/t6' ], [ "path('/')->relative('/t1/t2/t3')", '../../..' ], [ "path('///')->relative('/t1/t2/t3')", '../../..' ], [ "path('/.')->relative('/t1/t2/t3')", '../../..' ], [ "path('/./')->relative('/t1/t2/t3')", '../../..' ], [ "path('/t1/t2/t3')->relative( '/')", 't1/t2/t3' ], [ "path('/t1/t2/t3')->relative( '/t1')", 't2/t3' ], [ "path('t1/t2/t3')->relative( 't1')", 't2/t3' ], [ "path('t1/t2/t3')->relative( 't4')", '../t1/t2/t3' ], [ "path('.')->relative( '.')", '.' ], [ "path('/')->relative( '/')", '.' ], [ "path('../t1')->relative( 't2/t3')", '../../../t1' ], [ "path('t1')->relative( 't2/../t3')", '../t1' ], [ "path('t4')->absolute('/t1/t2/t3')", '/t1/t2/t3/t4' ], [ "path('t4/t5')->absolute('/t1/t2/t3')", '/t1/t2/t3/t4/t5' ], [ "path('.')->absolute('/t1/t2/t3')", '/t1/t2/t3' ], [ "path('///../../..//./././a//b/.././c/././')", '/a/b/../c', '/a/c' ], [ "path('a/../../b/c')", 'a/../../b/c', '../b/c' ], [ "path('..')->absolute('/t1/t2/t3')", '/t1/t2/t3/..', '/t1/t2' ], [ "path('../t4')->absolute('/t1/t2/t3')", '/t1/t2/t3/../t4', '/t1/t2/t4' ], # need to wash through rootdir->absolute->child to pick up volume on Windows [ "path('/t1')->absolute('/t1/t2/t3')", Path::Tiny->rootdir->absolute->child("t1") ], ); my @win32_tests; # this is lazy so we don't invoke any calls unless we're on Windows if ($IS_WIN32) { @win32_tests = ( [ "path('/')", '/' ], [ "path('/', '../')", '/' ], [ "path('/', '..\\')", '/' ], [ "path('\\', '../')", '/' ], [ "path('\\', '..\\')", '/' ], [ "path('\\d1\\','d2')", '/d1/d2' ], [ "path('\\d1','d2')", '/d1/d2' ], [ "path('\\d1','\\d2')", '/d1/d2' ], [ "path('\\d1','\\d2\\')", '/d1/d2' ], [ "path('d1','d2','d3')", 'd1/d2/d3' ], [ "path('\\', 'foo')", '/foo' ], [ "path('a','b','c')", 'a/b/c' ], [ "path('a','b','.\\c')", 'a/b/c' ], [ "path('.\\a','b','c')", 'a/b/c' ], [ "path('c')", 'c' ], [ "path('.\\c')", 'c' ], [ "path('a/..','../b')", '../b' ], [ "path('a\\..\\..\\b\\c')", '../b/c' ], [ "path('//a\\b//c')", '//a/b/c' ], [ "path('/a/..../c')", '/a/..../c' ], [ "path('//a/b\\c')", '//a/b/c' ], [ "path('////')", '/' ], [ "path('//')", '/' ], [ "path('/.')", '/' ], [ "path('//a/b/../../c')", '//a/b/c' ], [ "path('//a/b/c/../d')", '//a/b/d' ], [ "path('//a/b/c/../../d')", '//a/b/d' ], [ "path('/a/b/c/../../d')", '/a/d' ], [ "path('\\../temp\\')", '/temp' ], [ "path('\\../')", '/' ], [ "path('\\..\\')", '/' ], [ "path('/../')", '/' ], [ "path('/../')", '/' ], [ "path('d1/../foo')", 'foo' ], # if there's no C drive, getdcwd will probably return '', so fake it [ "path('C:')", path( eval { Cwd::getdcwd("C:") } \|\| "C:/" ) ], [ "path('\\\\server\\share\\')", '//server/share/' ], [ "path('\\\\server\\share')", '//server/share/' ], [ "path('//server/share/')", '//server/share/' ], [ "path('//server/share')", '//server/share/' ], [ "path('//d1','d2')", '//d1/d2/' ], ); # These test require no "A:" drive mapped my $drive_a_cwd = Cwd::getdcwd("A:"); $drive_a_cwd = "" unless defined $drive_a_cwd; if ( $drive_a_cwd eq "" ) { push @win32_tests, [ "path('A:/d1','d2','d3')", 'A:/d1/d2/d3' ], [ "path('A:/')", 'A:/' ], [ "path('A:', 'foo')", 'A:/foo' ], [ "path('A:', 'foo')", 'A:/foo' ], [ "path('A:f')", 'A:/f' ], [ "path('A:/')", 'A:/' ], [ "path('a:/')", 'A:/' ],; } } # Tries a named function with the given args and compares the result against # an expected result. Works with functions that return scalars or arrays. for ( @tests, $IS_WIN32 ? @win32_tests : () ) { my ( $function, $expected, $win32case ) = @$_; $expected = $win32case if $IS_WIN32 && $win32case; $function =~ s#\\#\\\\#g; my $got = join ',', eval $function; if ($@) { is( $@, '', $function ); } else { is( $got, $expected, $function ); } } done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��overloading.t��0000644��00000001026�15125143206�0007240 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use TestUtils qw/exception/; use Path::Tiny; my $path = path("t/stringify.t"); is( "$path", "t/stringify.t", "stringify via overloading" ); is( $path->stringify, "t/stringify.t", "stringify via method" ); ok( $path, "boolifies to true" ); done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��normalize.t��0000644��00000003473�15125143206�0006737 0��ustar�00��use Test::More; use File::Spec; use_ok( 'Test::File' ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Try it when it should work subtest file_spec_unix => sub { my $module = 'File::Spec::Unix'; use_ok( $module ); local @File::Spec::ISA = ( $module ); my $file = '/foo/bar/baz'; my $normalized = Test::File::_normalize( $file ); is( $normalized, $file, "Normalize gives same path for unix" ); }; subtest file_spec_win32 => sub { my $module = 'File::Spec::Win32'; use_ok( $module ); local @File::Spec::ISA = ( $module ); my $file = '/foo/bar/baz'; my $normalized = Test::File::_normalize( $file ); isnt( $normalized, $file, "Normalize gives different path for Win32" ); is( $normalized, '\foo\bar\baz', "Normalize gives right path for Win32" ); }; subtest file_spec_mac => sub { my $module = 'File::Spec::Mac'; use_ok( $module ); local @File::Spec::ISA = ( $module ); my $file = '/foo/bar/baz'; my $normalized = Test::File::_normalize( $file ); isnt( $normalized, $file, "Normalize gives different path for Mac" ); is( $normalized, 'foo:bar:baz', "Normalize gives right path for Mac" ); }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Try it when it shouldn't work subtest normalize_undef => sub { my $normalized = Test::File::_normalize( undef ); ok( ! defined $normalized, "Passing undef fails" ); }; subtest normalize_empty => sub { my $normalized = Test::File::_normalize( '' ); ok( defined $normalized, "Passing empty string returns defined value" ); is( $normalized, '', "Passing empty string returns empty string" ); ok( ! $normalized, "Passing empty string fails" ); }; subtest normalize_empty => sub { my $normalized = Test::File::_normalize(); ok( ! defined $normalized, "Passing nothing fails" ); }; done_testing(); ��input_output_no_PU_UU.t��0000644��00000001103�15125143206�0011213 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; # Tiny equivalent of Devel::Hide use lib map { my ( $m, $c ) = ( $_, qq{die "Can't locate $_ (hidden)\n"} ); sub { return unless $_[1] eq $m; open my $fh, "<", \$c; return $fh } } qw{Unicode/UTF8.pm PerlIO/utf8_strict.pm}; note "Hiding Unicode::UTF8 and PerlIO::utf8_strict"; do "./t/input_output.t" or die $@ \|\| $!; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��visit.t��0000644��00000000677�15125143206�0006100 0��ustar�00��use strict; use warnings; use Test::More tests => 3; use Path::Tiny; path('t')->visit(sub{ return [ ] }); pass "visit callback doesn't choke on random returned refs"; my $all; my $terminated; path('t')->visit(sub{ $all++ }); path('t')->visit(sub{ $terminated++; return \0 if $terminated == 10 }); is $terminated => 10, "terminated before the whole dir was read"; cmp_ok $all, '>=', $terminated, "we have more than 10 tests in that dir"; ��mkpath.t��0000644��00000001663�15125143206�0006222 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use File::Temp (); use lib 't/lib'; use TestUtils qw/exception/; use Path::Tiny; my $tempdir = File::Temp->newdir; my $path = path($tempdir)->child("foo"); ok( !-e $path, "target directory not created yet" ); ok( $path->mkpath, "mkpath on directory returned true" ); ok( -d $path, "target directory created" ); if ( $^O ne 'MSWin32' ) { my $path2 = path($tempdir)->child("bar"); ok( !-e $path2, "target directory not created yet" ); ok( $path2->mkpath( { mode => 0700 } ), "mkpath on directory with mode" ); if ( $^O ne 'msys' ) { is( $path2->stat->mode & 0777, 0700, "correct mode" ); } ok( -d $path2, "target directory created" ); } done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��exception.t��0000644��00000002414�15125143206�0006727 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use TestUtils qw/exception/; use Path::Tiny; my $err; $err = exception { path("aljfakdlfadks")->slurp }; like( $err, qr/at \Q$0\E/, "exception reported at caller's package" ); for my $m (qw/append iterator lines lines_raw lines_utf8 slurp spew/) { $err = exception { path("foo")->$m( { wibble => 1 } ) }; like( $err, qr/Invalid option\(s\) for $m: wibble/, "$m bad args" ); } $err = exception { path("foo")->visit( sub { 1 }, { wibble => 1 } ); }; like( $err, qr/Invalid option\(s\) for visit: wibble/, "visit bad args" ); # exclude append/spew because they handle hash/not-hash themselves my $scalar = [qw/array ref/]; for my $m (qw/iterator lines lines_raw lines_utf8 slurp/) { $err = exception { path("foo")->$m($scalar) }; like( $err, qr/Options for $m must be a hash reference/, "$m not hashref" ); } $err = exception { path("foo")->visit( sub { 1 }, $scalar ); }; like( $err, qr/Options for visit must be a hash reference/, "visit not hashref" ); done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # vim: ts=4 sts=4 sw=4 et: ��zz-atomic.t��0000644��00000001632�15125143206�0006647 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; BEGIN { plan skip_all => "Can't mock random() with Path::Tiny already loaded" if $INC{'Path/Tiny.pm'}; eval "use Test::MockRandom 'Path::Tiny';"; plan skip_all => "Test::MockRandom required for atomicity tests" if $@; } use lib 't/lib'; use TestUtils qw/exception/; use Path::Tiny; srand(0); subtest "spew (atomic)" => sub { my $file = Path::Tiny->tempfile; ok( $file->spew("original"), "spew" ); is( $file->slurp, "original", "original file" ); my $tmp = $file->[Path::Tiny::PATH] . $$ . "0"; open my $fh, ">", $tmp; ok( $fh, "opened collision file '$tmp'" ); print $fh "collide!"; close $fh; my $error = exception { ok( $file->spew("overwritten"), "spew" ) }; ok( $error, "spew errors if the temp file exists" ); is( $file->slurp(), "original", "original file intact" ); }; done_testing(); ��temp.t��0000644��00000011763�15125143206�0005705 0��ustar�00��use 5.008001; use strict; use warnings; use Cwd; # hack around https://bugs.activestate.com/show_bug.cgi?id=104767 use Test::More 0.96; use File::Spec::Unix; use lib 't/lib'; use TestUtils qw/exception tempd/; use Path::Tiny; subtest "tempdir" => sub { my $tempdir = Path::Tiny->tempdir; isa_ok( $tempdir->cached_temp, 'File::Temp::Dir', "cached_temp" ); my $string = $tempdir->stringify; ok( $tempdir->exists, "tempdir exists" ); undef $tempdir; ok( !-e $string, "tempdir destroyed" ); }; subtest "tempfile" => sub { my $tempfile = Path::Tiny->tempfile; isa_ok( $tempfile->cached_temp, 'File::Temp', "cached_temp" ); my $string = $tempfile->stringify; ok( $tempfile->exists, "tempfile exists" ); undef $tempfile; ok( !-e $string, "tempfile destroyed" ); }; subtest "tempdir w/ TEMPLATE" => sub { my $tempdir = Path::Tiny->tempdir( TEMPLATE => "helloXXXXX" ); like( $tempdir, qr/hello/, "found template" ); }; subtest "tempfile w/ TEMPLATE" => sub { my $tempfile = Path::Tiny->tempfile( TEMPLATE => "helloXXXXX" ); like( $tempfile, qr/hello/, "found template" ); }; subtest "tempdir w/ leading template" => sub { my $tempdir = Path::Tiny->tempdir("helloXXXXX"); like( $tempdir, qr/hello/, "found template" ); }; subtest "tempfile w/ leading template" => sub { my $tempfile = Path::Tiny->tempfile("helloXXXXX"); like( $tempfile, qr/hello/, "found template" ); }; subtest "tempfile handle" => sub { my $tempfile = Path::Tiny->tempfile; my $fh = $tempfile->filehandle; is( ref $tempfile->[5], 'File::Temp', "cached File::Temp object" ); is( fileno $tempfile->[5], undef, "cached handle is closed" ); }; subtest "survives absolute" => sub { my $wd = tempd; my $tempdir = Path::Tiny->tempdir( DIR => '.' )->absolute; ok( -d $tempdir, "exists" ); }; subtest "realpath option" => sub { my $wd = tempd; my $tempdir = Path::Tiny->tempdir( { realpath => 1 }, DIR => '.' ); is( $tempdir, $tempdir->realpath, "tempdir has realpath" ); my $tempfile = Path::Tiny->tempfile( { realpath => 1 }, DIR => '.' ); is( $tempfile, $tempfile->realpath, "tempfile has realpath" ); }; subtest "cached_temp on non tempfile" => sub { my $path = path("abcdefg"); eval { $path->cached_temp }; like( $@, qr/has no cached File::Temp object/, "cached_temp error message" ); }; subtest "tempdir w/ leading template as instance method" => sub { my $wd = tempd; my $basedir = Path::Tiny->cwd; my $repodir = $basedir->child('whatever'); $repodir->remove_tree if $repodir->exists; $repodir->mkdir; my $tempdir = $repodir->tempdir("helloXXXXX"); like( $tempdir, qr/hello/, "found template" ); ok( scalar($repodir->children) > 0, 'something was created' ); my $basename = $tempdir->basename; ok( -d $repodir->child($basename), "right directory exists" ); }; subtest "tempdir w/ leading template as instance method" => sub { my $wd = tempd; my $basedir = Path::Tiny->cwd; my $repodir = $basedir->child('whatever'); $repodir->remove_tree if $repodir->exists; $repodir->mkdir; my $tempdir = $repodir->tempdir("helloXXXXX"); like( $tempdir, qr/hello/, "found template" ); ok( scalar($repodir->children) > 0, 'something was created' ); my $basename = $tempdir->basename; ok( -d $repodir->child($basename), "right directory exists" ); }; subtest "tempfile w/out leading template as instance method" => sub { my $wd = tempd; my $basedir = Path::Tiny->cwd; my $repodir = $basedir->child('whatever'); $repodir->remove_tree if $repodir->exists; $repodir->mkdir; my $tempfile = $repodir->tempfile( TEMPLATE => "helloXXXXX" ); like( $tempfile, qr/hello/, "found template" ); ok( scalar($repodir->children) > 0, 'something was created' ); my $basename = $tempfile->basename; ok( -e $repodir->child($basename), "right file exists" ); }; subtest "tempfile w/out leading template as instance method" => sub { my $wd = tempd; my $basedir = Path::Tiny->cwd; my $repodir = $basedir->child('whatever'); $repodir->remove_tree if $repodir->exists; $repodir->mkdir; my $tempfile = $repodir->tempfile( TEMPLATE => "helloXXXXX"); like( $tempfile, qr/hello/, "found template" ); ok( scalar($repodir->children) > 0, 'something was created' ); my $basename = $tempfile->basename; ok( -e $repodir->child($basename), "right file exists" ); }; subtest "tempfile, instance method, overridden DIR" => sub { my $wd = tempd; my $basedir = Path::Tiny->cwd; my $repodir = $basedir->child('whatever'); $repodir->remove_tree if $repodir->exists; $repodir->mkdir; my $bd = $basedir->stringify; my $tempfile = $repodir->tempfile("helloXXXXX", DIR => $bd); ok( $tempfile->parent ne $bd ), "DIR is overridden"; }; done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��filesystem.t��0000644��00000033506�15125143206�0007123 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use File::Temp qw(tmpnam tempdir); use File::Spec; use Cwd; use lib 't/lib'; use TestUtils qw/exception has_symlinks/; use Path::Tiny; # Tests adapted from Path::Class t/basic.t my $file = path( scalar tmpnam() ); ok $file, "Got a filename via tmpnam()"; { my $fh = $file->openw; ok $fh, "Opened $file for writing"; ok print( $fh "Foo\n" ), "Printed to $file"; } ok -e $file, "$file should exist"; ok $file->is_file, "it's a file!"; if ( -e "/dev/null" ) { ok( path("/dev/null")->is_file, "/dev/null is_file, too" ); } my ( $volume, $dirname, $basename ) = map { s{\\}{/}; $_ } File::Spec->splitpath($file); is( $file->volume, $volume, "volume correct" ); is( $file->volume, $volume, "volume cached " ); # for coverage is( $file->dirname, $dirname, "dirname correct" ); is( $file->basename, $basename, "basename correct" ); { my $fh = $file->openr; is scalar <$fh>, "Foo\n", "Read contents of $file correctly"; } note "stat"; { my $stat = $file->stat; ok $stat; cmp_ok $stat->mtime, '>', time() - 20; # Modified within last 20 seconds $stat = $file->parent->stat; ok $stat; } note "stat/lstat with no file"; { my $file = "i/do/not/exist"; ok exception { path($file)->stat }; ok exception { path($file)->lstat }; } 1 while unlink $file; ok not -e $file; my $dir = path( tempdir( TMPDIR => 1, CLEANUP => 1 ) ); ok $dir; ok -d $dir; ok $dir->is_dir, "It's a directory!"; $file = $dir->child('foo.x'); $file->touch; ok -e $file; my $epoch = time - 10; utime $epoch, $epoch, $file; $file->touch; ok( $file->stat->mtime > $epoch, "touch sets utime as current time" ); $file->touch($epoch); ok( $file->stat->mtime == $epoch, "touch sets utime as 10 secs before" ); { my @files = $dir->children; is scalar @files, 1 or diag explain \@files; ok scalar grep { /foo\.x/ } @files; } ok $dir->remove_tree, "Removed $dir"; ok !-e $dir, "$dir no longer exists"; ok !$dir->remove_tree, "Removing non-existent dir returns false"; my $tmpdir = Path::Tiny->tempdir; { $dir = path( $tmpdir, 'foo', 'bar' ); $dir->parent->remove_tree if -e $dir->parent; ok $dir->mkdir, "Created $dir"; ok -d $dir, "$dir is a directory"; $dir = $dir->parent; ok $dir->remove_tree( { safe => 1 } ); # check that we pass through args ok !-e $dir; } { $dir = path( $tmpdir, 'foo' ); ok $dir->mkdir; ok $dir->child('dir')->mkdir; ok -d $dir->child('dir'); ok $dir->child('file.x')->touch; ok $dir->child('0')->touch; ok $dir->child('foo/bar/baz.txt')->touchpath; subtest 'iterator' => sub { my @contents; my $iter = $dir->iterator; while ( my $file = $iter->() ) { push @contents, $file; } is scalar @contents, 4 or diag explain \@contents; is( $iter->(), undef, "exhausted iterator is undef" ); my $joined = join ' ', sort map $_->basename, grep { -f $_ } @contents; is $joined, '0 file.x' or diag explain \@contents; my ($subdir) = grep { $_ eq $dir->child('dir') } @contents; ok $subdir; is -d $subdir, 1; my ($file) = grep { $_ eq $dir->child('file.x') } @contents; ok $file; is -d $file, ''; }; subtest 'visit' => sub { my @contents; $dir->visit( sub { push @contents, $_[0] } ); is scalar @contents, 4 or diag explain \@contents; my $joined = join ' ', sort map $_->basename, grep { -f $_ } @contents; is $joined, '0 file.x' or diag explain \@contents; my ($subdir) = grep { $_ eq $dir->child('dir') } @contents; ok $subdir; is -d $subdir, 1; my ($file) = grep { $_ eq $dir->child('file.x') } @contents; ok $file; is -d $file, ''; }; ok $dir->remove_tree; ok !-e $dir; # Try again with directory called '0', in curdir my $orig = Path::Tiny->cwd; ok $dir->mkdir; ok chdir($dir); my $dir2 = path("."); ok $dir2->child('0')->mkdir; ok -d $dir2->child('0'); subtest 'iterator' => sub { my @contents; my $iter = $dir2->iterator; while ( my $file = $iter->() ) { push @contents, $file; } ok grep { $_ eq '0' } @contents; }; subtest 'visit' => sub { my @contents; $dir2->visit( sub { push @contents, $_[0] } ); ok grep { $_ eq '0' } @contents; }; ok chdir($orig); ok $dir->remove_tree; ok !-e $dir; } { my $file = path( $tmpdir, 'slurp' ); ok $file; my $fh = $file->openw or die "Can't create $file: $!"; print $fh "Line1\nLine2\n"; close $fh; ok -e $file; my $content = $file->slurp; is $content, "Line1\nLine2\n"; my @content = $file->lines; is_deeply \@content, [ "Line1\n", "Line2\n" ]; @content = $file->lines( { chomp => 1 } ); is_deeply \@content, [ "Line1", "Line2" ]; ok( $file->remove, "removing file" ); ok !-e $file, "file is gone"; ok !$file->remove, "removing file again returns false"; my $subdir = $tmpdir->child('subdir'); ok $subdir->mkdir; ok exception { $subdir->remove }, "calling 'remove' on a directory throws"; ok rmdir $subdir; my $orig = Path::Tiny->cwd; ok chdir $tmpdir; my $zero_file = path '0'; ok $zero_file->openw; ok $zero_file->remove, "removing file called '0'"; ok chdir $orig; } { my $file = path( $tmpdir, 'slurp' ); ok $file; my $fh = $file->openw(':raw') or die "Can't create $file: $!"; print $fh "Line1\r\nLine2\r\n\302\261\r\n"; close $fh; ok -e $file; my $content = $file->slurp( { binmode => ':raw' } ); is $content, "Line1\r\nLine2\r\n\302\261\r\n", "slurp raw"; my $line3 = "\302\261\n"; utf8::decode($line3); $content = $file->slurp( { binmode => ':crlf:utf8' } ); is $content, "Line1\nLine2\n" . $line3, "slurp+crlf+utf8"; my @content = $file->lines( { binmode => ':crlf:utf8' } ); is_deeply \@content, [ "Line1\n", "Line2\n", $line3 ], "lines+crlf+utf8"; chop($line3); @content = $file->lines( { chomp => 1, binmode => ':crlf:utf8' } ); is_deeply \@content, [ "Line1", "Line2", $line3 ], "lines+chomp+crlf+utf8"; $file->remove; ok not -e $file; } { my $file = path( $tmpdir, 'spew' ); $file->remove() if $file->exists; $file->spew( { binmode => ':raw' }, "Line1\r\n" ); $file->append( { binmode => ':raw' }, "Line2" ); my $content = $file->slurp( { binmode => ':raw' } ); is( $content, "Line1\r\nLine2" ); } { # Make sure we can make an absolute/relative roundtrip my $cwd = path("."); is $cwd, $cwd->absolute->relative, "from $cwd to " . $cwd->absolute . " to " . $cwd->absolute->relative; } { # realpath should resolve .. my $lib = path("t/../lib"); my $real = $lib->realpath; unlike $real, qr/\.\./, "updir gone from realpath"; my $abs_lib = $lib->absolute; my $abs_t = path("t")->absolute; my $case = $abs_t->child("../lib"); is( $case->realpath, $lib->realpath, "realpath on absolute" ); # non-existent directory in realpath should throw error eval { path("lkajdfak/djslakdj")->realpath }; like( $@, qr/Error resolving realpath/, "caught error from realpath on non-existent dir" ); # but non-existent basename in realpath should throw error eval { path("./djslakdj")->realpath }; is( $@, '', "no error from realpath on non-existent last component" ); } subtest "move()" => sub { subtest "dest is a file (and does not exist)" => sub { my $file = $tmpdir->child("mv-foo.txt"); $file->spew("Hello World\n"); my $moveto = $tmpdir->child("mv-bar.txt"); ok !-e $moveto, "destination does not exist before"; my $result = $file->move("$moveto"); is "$result" => "$moveto", "returned the right file"; is $moveto->slurp, "Hello World\n", "target exists and matches orig"; ok !$file->exists, "orig no longer exists"; }; subtest "dest is a dir" => sub { my $file = $tmpdir->child("mv-dir.txt"); $file->spew("Hello World\n"); my $anothertmpdir = Path::Tiny->tempdir; my $result = $file->move($anothertmpdir); is "$result" => "$anothertmpdir/mv-dir.txt", "returned the right file"; is $result->slurp, "Hello World\n", "target exists and matches orig"; ok !$file->exists, "orig no longer exists"; }; subtest "dest file already exists" => sub { my $file = $tmpdir->child("mv-non.txt"); $file->spew("Hello World\n"); my $anothertmpdir = Path::Tiny->tempdir; my $dest = $anothertmpdir->child( "move-it.there"); $dest->spew( "Original Content\n" ); ok -f $dest, "destination file exists"; my $result; { local ( $!, $@ ); $result = $file->move("$dest"); is $@, undef, q[$@ - no errors leaked on success]; is $!, "", q[$! - no errors leaked on success]; } is "$result" => $dest, "returned the right file"; is $result->slurp, "Hello World\n", "target exists and matches orig"; ok !$file->exists, "orig no longer exists"; }; subtest "dest parent dir does not exist" => sub { my $file = $tmpdir->child("mv-noparent.txt"); $file->spew("Hello World\n"); my $anothertmpdir = Path::Tiny->tempdir; my $result = eval { $file->move("$anothertmpdir/rutroh/yo.txt") }; ok !$result, "does not return true"; like "$@", qr/move/, "throws error"; ok $file->exists, "orig still exists"; } }; subtest "copy()" => sub { my $file = $tmpdir->child("foo.txt"); $file->spew("Hello World\n"); my $copy; subtest "dest is a file" => sub { $copy = $tmpdir->child("bar.txt"); my $result = $file->copy($copy); is "$result" => "$copy", "returned the right file"; is( $copy->slurp, "Hello World\n", "file copied" ); }; subtest "dest is a dir" => sub { # new tempdir not to clobber the original foo.txt my $tmpdir = Path::Tiny->tempdir; my $result = $file->copy($tmpdir); is "$result" => "$tmpdir/foo.txt", "returned the right file"; is $result->slurp, "Hello World\n", "file copied"; }; subtest "try some different chmods" => sub { ok( $copy->chmod(0000), "chmod(0000)" ); ok( $copy->chmod("0400"), "chmod('0400')" ); SKIP: { skip "No exception if run as root", 1 if $> == 0; skip "No exception writing to read-only file", 1 unless exception { open my $fh, ">", "$copy" or die }; # probe if actually read-only my $error = exception { $file->copy($copy) }; ok( $error, "copy throws error if permission denied" ); like( $error, qr/\Q$file/, "error messages includes the source file name" ); like( $error, qr/\Q$copy/, "error messages includes the destination file name" ); } ok( $copy->chmod("u+w"), "chmod('u+w')" ); }; }; { $tmpdir->child( "subdir", "touched.txt" )->touchpath->spew("Hello World\n"); is( $tmpdir->child( "subdir", "touched.txt" )->slurp, "Hello World\n", "touch can chain" ); } { # Only run if a 255 length filename is allowed. Test checks that the temp # file created doesn't exceed 255 characters. my $file = $tmpdir->child("A" x 255); if ( eval { $file->touch; 1 } ) {; ok( path($file)->spew("Hello"), "spew to long filename" ); } } SKIP: { my $newtmp = Path::Tiny->tempdir; my $file = $newtmp->child("foo.txt"); my $link = $newtmp->child("bar.txt"); $file->spew("Hello World\n"); skip "symlink unavailable", 1 unless has_symlinks(); eval { symlink $file => $link }; ok( $link->lstat->size, "lstat" ); is( $link->realpath, $file->realpath, "realpath resolves symlinks" ); ok $link->remove, 'remove symbolic link'; ok $file->remove; $file = $newtmp->child("foo.txt"); $link = $newtmp->child("bar.txt"); $file->spew("Hello World\n"); ok symlink $file => $link; ok $file->remove; ok $link->remove, 'remove broken symbolic link'; my $dir = $newtmp->child('foo'); $link = $newtmp->child("bar"); ok $dir->mkdir; ok -d $dir; $file = $dir->child("baz.txt"); $file->spew("Hello World\n"); ok symlink $dir => $link; ok $link->remove_tree, 'remove_tree symbolic link'; ok $dir->remove_tree; $dir = $newtmp->child('foo'); $link = $newtmp->child("bar"); ok $dir->mkdir; ok -d $dir; $file = $dir->child("baz.txt"); $file->spew("Hello World\n"); ok symlink $dir => $link; ok $dir->remove_tree; ok $link->remove_tree, 'remove_tree broken symbolic link'; $file = $newtmp->child("foo.txt"); $link = $newtmp->child("bar.txt"); my $link2 = $newtmp->child("baz.txt"); $file->spew("Hello World\n"); ok symlink $file => $link; ok symlink $link => $link2; $link2->spew("Hello Perl\n"); ok -l $link2, 'path is still symbolic link after spewing'; is readlink($link2), $link, 'symbolic link is available after spewing'; is readlink($link), $file, 'symbolic link is available after spewing'; is $file->slurp, "Hello Perl\n", 'spewing follows the link and replace the destination instead'; } # We don't have subsume so comment these out. Keep in case we # implement it later ##{ ## my $t = path( 't'); ## my $foo_bar = $t->child('foo','bar'); ## $foo_bar->remove; # Make sure it doesn't exist ## ## ok $t->subsumes($foo_bar), "t subsumes t/foo/bar"; ## ok !$t->contains($foo_bar), "t doesn't contain t/foo/bar"; ## ## $foo_bar->mkdir; ## ok $t->subsumes($foo_bar), "t still subsumes t/foo/bar"; ## ok $t->contains($foo_bar), "t now contains t/foo/bar"; ## ## $t->child('foo')->remove; ##} done_testing; ��lib/TestUtils.pm��0000644��00000003116�15125143206�0007610 0��ustar�00��use 5.008001; use strict; use warnings; package TestUtils; use Carp; use Cwd qw/getcwd/; use Config; use File::Temp 0.19 (); use Exporter; our @ISA = qw/Exporter/; our @EXPORT = qw( exception pushd tempd has_symlinks ); # If we have Test::FailWarnings, use it BEGIN { eval { require Test::FailWarnings; 1 } and do { Test::FailWarnings->import }; } sub has_symlinks { return $Config{d_symlink} unless $^O eq 'msys' \|\| $^O eq 'MSWin32'; if ($^O eq 'msys') { # msys needs both `d_symlink` and a special environment variable return unless $Config{d_symlink}; return $ENV{MSYS} =~ /winsymlinks:nativestrict/; } elsif ($^O eq 'MSWin32') { # Perl 5.33.5 adds symlink support for MSWin32 but needs elevated # privileges so verify if we can use it for testing. my $wd=tempd(); open my $fh, ">", "foo"; return eval { symlink "foo", "bar" }; } } sub exception(&) { my $code = shift; my $success = eval { $code->(); 1 }; my $err = $@; return '' if $success; croak "Execution died, but the error was lost" unless $@; return $@; } sub tempd { return pushd( File::Temp->newdir ); } sub pushd { my $temp = shift; my $guard = TestUtils::_Guard->new( { temp => $temp, origin => getcwd(), code => sub { chdir $_[0]{origin} }, } ); chdir $guard->{temp} or croak("Couldn't chdir: $!"); return $guard; } package TestUtils::_Guard; sub new { bless $_[1], $_[0] } sub DESTROY { $_[0]{code}->( $_[0] ) } 1; ��README��0000644��00000000326�15125143206�0005424 0��ustar�00��Some test files are adapted from those in Path::Class. Path::Tiny isn't API compatible so some adjustments have been made. For the most part, these tests are here to see if it handles special cases the same way. ��has_same_bytes.t��0000644��00000004056�15125143206�0007723 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use TestUtils qw/exception has_symlinks/; use Path::Tiny; my $dir = Path::Tiny->tempdir; # identical contents in two files my $file1a = $dir->child("file1b.txt"); my $file1b = $dir->child("file1a.txt"); for my $f ( $file1a, $file1b ) { $f->spew("hello world"); } # different contents my $file2 = $dir->child("file2.txt"); $file2->spew("goodbye world"); # a directory, instead of a file my $subdir = $dir->child("subdir"); $subdir->mkdir; subtest "only files" => sub { ok( $file1a->has_same_bytes($file1a), "same file" ); ok( $file1a->has_same_bytes($file1b), "different files, same contents" ); ok( !$file1a->has_same_bytes($file2), "different files, different contents" ); }; subtest "symlinks" => sub { plan skip_all => "No symlink support" unless has_symlinks(); my $file1c = $dir->child("file1c.txt"); symlink "$file1a" => "$file1c"; ok( $file1a->has_same_bytes($file1c), "file compared to self symlink" ); ok( $file1c->has_same_bytes($file1a), "self symlink compared to file" ); }; subtest "exception" => sub { my $doesnt_exist = $dir->child("doesnt_exist.txt"); # Different OSes return different errors, so we just check for any error. ok( exception { $file1a->has_same_bytes($doesnt_exist) }, "file->has_same_bytes(doesnt_exist)" ); ok( exception { $doesnt_exist->has_same_bytes($file1a) }, "doesnt_exist->has_same_bytes(file)" ); ok( exception { $file1a->has_same_bytes($subdir) }, "file->has_same_bytes(dir)" ); ok( exception { $subdir->has_same_bytes($file1a) }, "dir->has_same_bytes(file)" ); ok( exception { $subdir->has_same_bytes($subdir) }, "dir->has_same_bytes(dir)" ); ok( exception { $subdir->has_same_bytes($dir) }, "dir->has_same_bytes(different_dir)" ); }; done_testing; # # This file is part of Path-Tiny # # This software is Copyright (c) 2014 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��Exporter.t��0000644��00000014626�15125143206�0006551 0��ustar�00��#!perl -w use strict; use warnings; # Can't use Test::Simple/More, they depend on Exporter. my $test; sub ok ($;$) { my($ok, $name) = @_; # You have to do it this way or VMS will get confused. printf "%sok %d%s\n", ($ok ? '' : 'not '), $test, (defined $name ? " - $name" : ''); printf "# Failed test at line %d\n", (caller)[2] unless $ok; $test++; return $ok; } BEGIN { $test = 1; print "1..34\n"; require Exporter; ok( 1, 'Exporter compiled' ); } our @Exporter_Methods = qw(import export_to_level require_version export_fail ); package Testing; require Exporter; our @ISA = qw(Exporter); # Make sure Testing can do everything its supposed to. foreach my $meth (@::Exporter_Methods) { ::ok( Testing->can($meth), "subclass can $meth()" ); } our %EXPORT_TAGS = ( This => [qw(stuff %left)], That => [qw(Above the @wailing)], tray => [qw(Fasten $seatbelt)], ); our @EXPORT = qw(lifejacket is); our @EXPORT_OK = qw(under &your $seat); our $VERSION = '1.05'; ::ok( Testing->require_version(1.05), 'require_version()' ); eval { Testing->require_version(1.11); 1 }; ::ok( $@, 'require_version() fail' ); ::ok( Testing->require_version(0), 'require_version(0)' ); sub lifejacket { 'lifejacket' } sub stuff { 'stuff' } sub Above { 'Above' } sub the { 'the' } sub Fasten { 'Fasten' } sub your { 'your' } sub under { 'under' } use vars qw($seatbelt $seat @wailing %left); $seatbelt = 'seatbelt'; $seat = 'seat'; @wailing = qw(AHHHHHH); %left = ( left => "right" ); BEGIN {is = \&Is}; sub Is { 'Is' }; Exporter::export_ok_tags(); my %tags = map { $_ => 1 } map { @$_ } values %EXPORT_TAGS; my %exportok = map { $_ => 1 } @EXPORT_OK; my $ok = 1; foreach my $tag (keys %tags) { $ok = exists $exportok{$tag}; } ::ok( $ok, 'export_ok_tags()' ); package Foo; Testing->import; ::ok( defined &lifejacket, 'simple import' ); my $got = eval {&lifejacket}; ::ok ( $@ eq "", 'check we can call the imported subroutine') or print STDERR "# \$\@ is $@\n"; ::ok ( $got eq 'lifejacket', 'and that it gave the correct result') or print STDERR "# expected 'lifejacket', got " . (defined $got ? "'$got'" : "undef") . "\n"; # The string eval is important. It stops $Foo::{is} existing when # Testing->import is called. ::ok( eval "defined &is", "Import a subroutine where exporter must create the typeglob" ); $got = eval "&is"; ::ok ( $@ eq "", 'check we can call the imported autoloaded subroutine') or chomp ($@), print STDERR "# \$\@ is $@\n"; ::ok ( $got eq 'Is', 'and that it gave the correct result') or print STDERR "# expected 'Is', got " . (defined $got ? "'$got'" : "undef") . "\n"; package Bar; my @imports = qw($seatbelt &Above stuff @wailing %left); Testing->import(@imports); ::ok( (! grep { my ($s, $n) = @$_; eval "\\$s$n != \\${s}Testing::$n" } map { /^(\W)(\w+)/ ? [$1, $2] : ['&', $_] } @imports), 'import by symbols' ); package Yar; my @tags = qw(:This :tray); Testing->import(@tags); ::ok( (! grep { my ($s, $n) = @$_; eval "\\$s$n != \\${s}Testing::$n" } map { /^(\W)(\w+)/ ? [$1, $2] : ['&', $_] } map { @$_ } @{$Testing::EXPORT_TAGS{@tags}}), 'import by tags' ); package Err; my @missing = qw(first second); eval { Testing->import(@missing) }; for my $func (@missing) { ::ok( $@ =~ /^"$func" is not exported by the Testing module$/m, "$func is not exported error message" ); } package Arrr; Testing->import(qw(!lifejacket)); ::ok( !defined &lifejacket, 'deny import by !' ); package Mars; Testing->import('/e/'); ::ok( (! grep { my ($s, $n) = @$_; eval "\\$s$n != \\${s}Testing::$n" } map { /^(\W)(\w+)/ ? [$1, $2] : ['&', $_] } grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK), 'import by regex'); package Venus; Testing->import('!/e/'); ::ok( (! grep { my ($s, $n) = @$_; eval "\\$s$n == \\${s}Testing::$n" } map { /^(\W)(\w+)/ ? [$1, $2] : ['&', $_] } grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK), 'deny import by regex'); ::ok( !defined &lifejacket, 'further denial' ); package More::Testing; our @ISA = qw(Exporter); our $VERSION = 0; eval { More::Testing->require_version(0); 1 }; ::ok(!$@, 'require_version(0) and $VERSION = 0'); package Yet::More::Testing; our @ISA = qw(Exporter); our $VERSION = 0; eval { Yet::More::Testing->require_version(10); 1 }; ::ok($@ !~ /\(undef\)/, 'require_version(10) and $VERSION = 0'); my $warnings; BEGIN { local $SIG{__WARN__} = sub { $warnings = join '', @_ }; package Testing::Unused::Vars; our @ISA = qw(Exporter); our @EXPORT = qw(this $TODO that); package Foo; Testing::Unused::Vars->import; } ::ok( !$warnings, 'Unused variables can be exported without warning' ) \|\| print "# $warnings\n"; package Moving::Target; our @ISA = qw(Exporter); our @EXPORT_OK = qw (foo); sub foo {"This is foo"}; sub bar {"This is bar"}; package Moving::Target::Test; Moving::Target->import ('foo'); ::ok (foo() eq "This is foo", "imported foo before EXPORT_OK changed"); push @Moving::Target::EXPORT_OK, 'bar'; Moving::Target->import ('bar'); ::ok (bar() eq "This is bar", "imported bar after EXPORT_OK changed"); package The::Import; use Exporter 'import'; ::ok(\&import == \&Exporter::import, "imported the import routine"); our @EXPORT = qw( wibble ); sub wibble {return "wobble"}; package Use::The::Import; The::Import->import; my $val = eval { wibble() }; ::ok($val eq "wobble", "exported importer worked"); # Check that Carp recognizes Exporter as internal to Perl require Carp; eval { Carp::croak() }; ::ok($Carp::Internal{Exporter}, "Carp recognizes Exporter"); ::ok($Carp::Internal{'Exporter::Heavy'}, "Carp recognizes Exporter::Heavy"); package Exporter::for::Tied::_; our @ISA = 'Exporter'; our @EXPORT = 'foo'; package Tied::_; sub TIESCALAR{bless[]} # no tie methods! { tie my $t, __PACKAGE__; for($t) { # $_ is now tied import Exporter::for::Tied::_; } } ::ok(1, 'import with tied $_'); # this should be loaded, but make sure require Exporter::Heavy; ::ok(Exporter->VERSION eq Exporter::Heavy->VERSION, 'Exporter and Exporter::Heavy have matching versions'); ��warn.t��0000644��00000001453�15125143206�0005702 0��ustar�00��#!perl -w # Can't use Test::Simple/More, they depend on Exporter. my $test; sub ok ($;$) { my($ok, $name) = @_; # You have to do it this way or VMS will get confused. printf "%sok %d%s\n", ($ok ? '' : 'not '), $test, (defined $name ? " - $name" : ''); printf "# Failed test at line %d\n", (caller)[2] unless $ok; $test++; return $ok; } BEGIN { $test = 1; print "1..2\n"; require Exporter; ok( 1, 'Exporter compiled' ); } package Foo; Exporter->import("import"); our @EXPORT_OK = qw/bar/; package main; { # [perl #39739] Exporter::Heavy ignores custom $SIG{__WARN__} handlers my @warn; local $SIG{__WARN__} = sub { push @warn, join "", @_ }; eval { Foo->import(":quux") }; ok(grep(/"quux" is not defined/, @warn), "warnings captured"); } ��use.t��0000644��00000000306�15125143206�0005523 0��ustar�00�� print "1..1\n"; my $ok; BEGIN { eval "use Exporter;"; $ok = !$@; } print( ($ok ? '' : 'not '), "ok - use Exporter;\n" ); print( "# Testing Exporter $Exporter::VERSION, Perl $], $^X\n" ); ��pod.t��0000644��00000000201�15125143206�0005503 0��ustar�00��use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); ��35limit.t��0000644��00000004337�15125143222�0006223 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use DBI::Const::GetInfoType; $\|= 1; my $rows = 0; my $sth; my $testInsertVals; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { mysql_bind_type_guessing => 1, RaiseError => 1, PrintError => 1, AutoCommit => 1 });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 117; ok(defined $dbh, "Connected to database"); ok($dbh->do("DROP TABLE IF EXISTS dbd_mysql_t35"), "making slate clean"); ok($dbh->do("CREATE TABLE dbd_mysql_t35 (id INT(4), name VARCHAR(64), name_limit VARCHAR(64), limit_by VARCHAR(64))"), "creating table"); ok(($sth = $dbh->prepare("INSERT INTO dbd_mysql_t35 VALUES (?,?,?,?)"))); for my $i (0..99) { my @chars = grep !/[0O1Iil]/, 0..9, 'A'..'Z', 'a'..'z'; my $random_chars = join '', map { $chars[rand @chars] } 0 .. 16; # save these values for later testing $testInsertVals->{$i} = $random_chars; ok(($rows = $sth->execute($i, $random_chars, $random_chars, $random_chars))); } ok($sth = $dbh->prepare("SELECT * FROM dbd_mysql_t35 LIMIT ?, ?"), 'testing prepare of select statement with LIMIT placeholders'); ok($sth->execute(20, 50), 'testing exec of bind vars for limit'); my ($row, $errstr, $array_ref); ok( (defined($array_ref = $sth->fetchall_arrayref) && (!defined($errstr = $sth->errstr) \|\| $sth->errstr eq ''))); ok(@$array_ref == 50); ok($sth = $dbh->prepare("SELECT * FROM dbd_mysql_t35 WHERE limit_by > ?"), "testing prepare of select statement with started by 'limit' column"); ok($sth->execute("foobar"), 'testing exec of bind vars for placeholder'); ok($sth->finish); ok($dbh->do("UPDATE dbd_mysql_t35 SET name_limit = ? WHERE id = ?", undef, "updated_string", 1)); ok($dbh->do("UPDATE dbd_mysql_t35 SET name = ? WHERE name_limit > ?", undef, "updated_string", 999999)); # newline before LIMIT ok($dbh->do(<<'SQL' UPDATE dbd_mysql_t35 SET name = ? LIMIT ? SQL , undef, "updated_string", 0)); # tab before LIMIT ok($dbh->do(<<'SQL' UPDATE dbd_mysql_t35 SET name = ? LIMIT ? SQL , undef, "updated_string", 0)); ok($dbh->do("DROP TABLE dbd_mysql_t35")); ok($dbh->disconnect); ��35prepare.t��0000644��00000006477�15125143222�0006552 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use lib 't', '.'; require 'lib.pl'; my ($row, $sth, $dbh); my ($def, $rows, $errstr, $ret_ref); use vars qw($test_dsn $test_user $test_password); eval {$dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1});}; if ($@) { plan skip_all => "no database connection"; } plan tests => 49; ok(defined $dbh, "Connected to database"); ok($dbh->do("DROP TABLE IF EXISTS dbd_mysql_t35prepare"), "Making slate clean"); ok($dbh->do("CREATE TABLE dbd_mysql_t35prepare (id INT(4), name VARCHAR(64))"), "Creating table"); ok($sth = $dbh->prepare("SHOW TABLES LIKE 'dbd_mysql_t35prepare'"), "Testing prepare show tables"); ok($sth->execute(), "Executing 'show tables'"); ok((defined($row= $sth->fetchrow_arrayref) && (!defined($errstr = $sth->errstr) \|\| $sth->errstr eq '')), "Testing if result set and no errors"); ok($row->[0] eq 'dbd_mysql_t35prepare', "Checking if results equal to 'dbd_mysql_t35prepare' \n"); ok($sth->finish, "Finishing up with statement handle"); ok($dbh->do("INSERT INTO dbd_mysql_t35prepare VALUES (1,'1st first value')"), "Inserting first row"); ok($sth= $dbh->prepare("INSERT INTO dbd_mysql_t35prepare VALUES (2,'2nd second value')"), "Preparing insert of second row"); ok(($rows = $sth->execute()), "Inserting second row"); ok($rows == 1, "One row should have been inserted"); ok($sth->finish, "Finishing up with statement handle"); ok($sth= $dbh->prepare("SELECT id, name FROM dbd_mysql_t35prepare WHERE id = 1"), "Testing prepare of query"); ok($sth->execute(), "Testing execute of query"); ok($ret_ref = $sth->fetchall_arrayref(), "Testing fetchall_arrayref of executed query"); ok($sth= $dbh->prepare("INSERT INTO dbd_mysql_t35prepare values (?, ?)"), "Preparing insert, this time using placeholders"); my $testInsertVals = {}; for (my $i = 0 ; $i < 10; $i++) { my @chars = grep !/[0O1Iil]/, 0..9, 'A'..'Z', 'a'..'z'; my $random_chars= join '', map { $chars[rand @chars] } 0 .. 16; # save these values for later testing $testInsertVals->{$i}= $random_chars; ok($rows= $sth->execute($i, $random_chars), "Testing insert row"); ok($rows= 1, "Should have inserted one row"); } ok($sth->finish, "Testing closing of statement handle"); ok($sth= $dbh->prepare("SELECT * FROM dbd_mysql_t35prepare WHERE id = ? OR id = ?"), "Testing prepare of query with placeholders"); ok($rows = $sth->execute(1,2), "Testing execution with values id = 1 or id = 2"); ok($ret_ref = $sth->fetchall_arrayref(), "Testing fetchall_arrayref (should be four rows)"); note "RETREF " . scalar @$ret_ref . "\n"; ok(@{$ret_ref} == 4 , "\$ret_ref should contain four rows in result set"); ok($sth= $dbh->prepare("DROP TABLE IF EXISTS dbd_mysql_t35prepare"), "Testing prepare of dropping table"); ok($sth->execute(), "Executing drop table"); # Bug #20153: Fetching all data from a statement handle does not mark it # as finished ok($sth= $dbh->prepare("SELECT 1"), "Prepare - Testing bug #20153"); ok($sth->execute(), "Execute - Testing bug #20153"); ok($sth->fetchrow_arrayref(), "Fetch - Testing bug #20153"); ok(!($sth->fetchrow_arrayref()),"Not Fetch - Testing bug #20153"); # Install a handler so that a warning about unfreed resources gets caught $SIG{__WARN__} = sub { die @_ }; ok($dbh->disconnect(), "Testing disconnect"); ��81procs.t��0000644��00000005326�15125143222�0006233 0��ustar�00��use strict; use warnings; use lib 't', '.'; require 'lib.pl'; use DBI; use Test::More; use vars qw($test_dsn $test_user $test_password); my ($row, $vers, $test_procs, $dbh, $sth); eval {$dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1})}; if ($@) { plan skip_all => "no database connection"; } # # DROP/CREATE PROCEDURE will give syntax error # for versions < 5.0 # if ($dbh->{mysql_serverversion} < 50000) { plan skip_all => "You must have MySQL version 5.0 and greater for this test to run"; } if (!CheckRoutinePerms($dbh)) { plan skip_all => "Your test user does not have ALTER_ROUTINE privileges."; } plan tests => 32; $dbh->disconnect(); ok ($dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1})); ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t81procs"); my $drop_proc= "DROP PROCEDURE IF EXISTS testproc"; ok $dbh->do($drop_proc); my $proc_create = <<EOPROC; create procedure testproc() deterministic begin declare a,b,c,d int; set a=1; set b=2; set c=3; set d=4; select a, b, c, d; select d, c, b, a; select b, a, c, d; select c, b, d, a; end EOPROC ok $dbh->do($proc_create); my $proc_call = 'CALL testproc()'; ok $dbh->do($proc_call); my $proc_select = 'SELECT @a'; ok ($sth = $dbh->prepare($proc_select)); ok $sth->execute(); ok $sth->finish; ok $dbh->do("DROP PROCEDURE testproc"); ok $dbh->do("drop procedure if exists test_multi_sets"); $proc_create = <<EOT; create procedure test_multi_sets () deterministic begin select user() as first_col; select user() as first_col, now() as second_col; select user() as first_col, now() as second_col, now() as third_col; end EOT ok $dbh->do($proc_create); ok ($sth = $dbh->prepare("call test_multi_sets()")); ok $sth->execute(); is $sth->{NUM_OF_FIELDS}, 1, "num_of_fields == 1"; my $resultset; ok ($resultset = $sth->fetchrow_arrayref()); ok defined $resultset; is @$resultset, 1, "1 row in resultset"; undef $resultset; ok $sth->more_results(); is $sth->{NUM_OF_FIELDS}, 2, "NUM_OF_FIELDS == 2"; ok ($resultset= $sth->fetchrow_arrayref()); ok defined $resultset; is @$resultset, 2, "2 rows in resultset"; undef $resultset; ok $sth->more_results(); is $sth->{NUM_OF_FIELDS}, 3, "NUM_OF_FIELDS == 3"; ok ($resultset= $sth->fetchrow_arrayref()); ok defined $resultset; is @$resultset, 3, "3 Rows in resultset"; is $sth->more_results(), 1, "each CALL returns a result to indicate the call status"; is $sth->{NUM_OF_FIELDS}, 0, "NUM_OF_FIELDS == 0"; ok !$sth->more_results(); local $SIG{__WARN__} = sub { die @_ }; ok $sth->finish; ok $dbh->disconnect(); ��rt61849-bind-param-buffer-overflow.t��0000644��00000001307�15125143222�0013110 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use vars qw($test_dsn $test_user $test_password); require "t/lib.pl"; my $INSECURE_VALUE_FROM_USER = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"; my $dbh = eval { DBI->connect($test_dsn, $test_user, $test_password, { PrintError => 0, RaiseError => 1, AutoCommit => 0 }) }; plan skip_all => "no database connection" if $@ or not $dbh; plan tests => 2; my $sth = $dbh->prepare("select * from unknown_table where id=?"); eval { $sth->bind_param(1, $INSECURE_VALUE_FROM_USER, 3) }; like $@, qr/Binding non-numeric field 1, value '$INSECURE_VALUE_FROM_USER' as a numeric!/, "bind_param failed on incorrect numeric value"; pass "perl interpreter did not crash"; ��40server_prepare_error.t��0000644��00000001710�15125143222�0011326 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use lib '.', 't'; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password); $test_dsn.= ";mysql_server_prepare=1;mysql_server_prepare_disable_fallback=1"; my $dbh; eval {$dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1})}; if ($@) { plan skip_all => "no database connection"; } if ($dbh->{mysql_clientversion} < 40103 or $dbh->{mysql_serverversion} < 40103) { plan skip_all => "SKIP TEST: You must have MySQL version 4.1.3 and greater for this test to run"; } plan tests => 3; # execute invalid SQL to make sure we get an error my $q = "select select select"; # invalid SQL $dbh->{PrintError} = 0; $dbh->{PrintWarn} = 0; my $sth; eval {$sth = $dbh->prepare($q);}; $dbh->{PrintError} = 1; $dbh->{PrintWarn} = 1; ok defined($DBI::errstr); cmp_ok $DBI::errstr, 'ne', ''; note "errstr $DBI::errstr\n" if $DBI::errstr; ok $dbh->disconnect(); ��71impdata.t��0000644��00000002116�15125143222�0006515 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use lib 't', '.'; require 'lib.pl'; use Test::More; $\| = 1; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1})}; if ($@) { plan skip_all => "no database connection"; } my $drh = $dbh->{Driver}; if (! defined $drh) { plan skip_all => "Can't obtain driver handle. Can't continue test"; } plan tests => 10; pass("Connected to database"); pass("Obtained driver handle"); my $connection_id1 = connection_id($dbh); is $drh->{Kids}, 1, "1 kid"; is $drh->{ActiveKids}, 1, "1 active kid"; my $imp_data = $dbh->take_imp_data; is $drh->{Kids}, 0, "no kids"; is $drh->{ActiveKids}, 0, "no active kids"; $dbh = DBI->connect( $test_dsn, $test_user, $test_password, { dbi_imp_data => $imp_data } ); my $connection_id2 = connection_id($dbh); is $connection_id1, $connection_id2, "got same session"; is $drh->{Kids}, 1, "1 kid"; is $drh->{ActiveKids}, 1, "1 active kid"; ok $dbh->disconnect, "Disconnect OK"; ��gh352.t��0000644��00000001162�15125143222�0005556 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use lib 't', '.'; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { diag $@; plan skip_all => "no database connection"; } plan tests => 2; # https://github.com/perl5-dbi/DBD-mysql/issues/352 # Calling prepare on a disconnected handle causes the call to mysql_real_escape_string to segfault my $sth; ok $dbh->disconnect; my $result = eval { $dbh->prepare('SELECT ?'); }; ok !$result ��51bind_type_guessing.t��0000644��00000013301�15125143222�0010753 0��ustar�00��use strict; use warnings; use DBI; use DBI::Const::GetInfoType; use Test::More; select(($\|=1,select(STDERR),$\|=1)[1]); use lib 't', '.'; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password); my ($dbh, $t); eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 1 });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 98; ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t51bind_type_guessing"), "drop table if exists dbd_mysql_t51bind_type_guessing"; my $create= <<"EOTABLE"; create table dbd_mysql_t51bind_type_guessing ( id bigint unsigned not null default 0 ) EOTABLE ok $dbh->do($create), "creating table"; my $statement= "insert into dbd_mysql_t51bind_type_guessing (id) values (?)"; my $sth1; ok $sth1= $dbh->prepare($statement); my $rows; ok $rows= $sth1->execute('9999999999999999'); cmp_ok $rows, '==', 1; $statement= "update dbd_mysql_t51bind_type_guessing set id = ?"; my $sth2; ok $sth2= $dbh->prepare($statement); ok $rows= $sth2->execute('9999999999999998'); cmp_ok $rows, '==', 1; $dbh->{mysql_bind_type_guessing}= 1; ok $rows= $sth1->execute('9999999999999997'); cmp_ok $rows, '==', 1; $statement= "update dbd_mysql_t51bind_type_guessing set id = ? where id = ?"; ok $sth2= $dbh->prepare($statement); ok $rows= $sth2->execute('9999999999999996', '9999999999999997'); my $retref; ok $retref= $dbh->selectall_arrayref( "select * from dbd_mysql_t51bind_type_guessing"); cmp_ok $retref->[0][0], '==', 9999999999999998; cmp_ok $retref->[1][0], '==', 9999999999999996; # checking varchars/empty strings/misidentification: $create= <<"EOTABLE"; create table dbd_mysql_t51bind_type_guessing ( id bigint default 0 not null, nn bigint default 0, dd double(12,4), str varchar(80), primary key (id) ) engine=innodb EOTABLE ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t51bind_type_guessing"), "drop table if exists dbd_mysql_t51bind_type_guessing"; ok $dbh->do($create), "creating table with int, double, and varchar"; my @sts; $t= "prepare insert integer col nn into dbd_mysql_t51bind_type_guessing"; ok $sts[0] = $dbh->prepare("insert into dbd_mysql_t51bind_type_guessing (id,nn) values (?,?)"), $t; $t= "prepare update double col dd dbd_mysql_t51bind_type_guessing"; ok $sts[1] = $dbh->prepare("update dbd_mysql_t51bind_type_guessing set dd = ? where id = ?"), $t; $t= "prepare update string col str dbd_mysql_t51bind_type_guessing"; ok $sts[2] = $dbh->prepare("update dbd_mysql_t51bind_type_guessing set str = ? where id = ?"), $t; # various values to try including issue 251 my @vals = ( 52.3, ' 77.7777', '.1', '5e3', +1, -1, undef, '5e', '1+', '+', '.', 'e5', ); my $val; # the tests for 'like' are when values fail to be inserted/updated for my $i (0 .. 11) { $val = $vals[$i]; if (defined $val) { $t= "insert int val $val id $i" } else { $t= "insert undef into int id $i"; } if ($i >= 8) { eval { $rows= $sts[0]->execute($i, $val); }; if ($i == 8) { like ($@, qr{Data truncated for column}, $t); } else { like ($@, qr{Incorrect integer value}, $t); } $rows= $sts[0]->execute($i, 0); } else { ok $rows= $sts[0]->execute($i, $val),$t; } if (defined $val) { $t= "update double val $val id $i"; } else { $t= "update double val undefined id $i"; } if ($i >= 7) { eval { $rows = $sts[1]->execute($val, $i); }; if ($dbh->{mysql_serverversion} < 90000) { like ($@, qr{Data truncated for column}, $t); } else { like ($@, qr{Incorrect DOUBLE value}, $t); } $rows= $sts[1]->execute(0, $i); } else { ok $rows= $sts[1]->execute($val,$i),$t; } if (defined $val) { $t= "update string val $val id $i"; } else { $t= "update string val undef id $i"; } ok $rows = $sts[2]->execute($val,$i),$t; } for my $i (0 .. 2) { $sts[$i]->finish(); } # expected results my $res= [ [ 0, 52, '52.3', '52.3' ], [ 1, 78, '77.7777', '77.7777' ], [ 2, 0, '0.1', '0.1' ], [ 3, 5000, '5000', '5e3' ], [ 4, 1, '1', '1' ], [ 5, -1, '-1', '-1' ], [ 6, undef, undef, undef ], [ 7, 5, '0', '5e' ], [ 8, 0, '0', '1+' ], [ 9, 0, '0', '+' ], [ 10, 0, '0', '.' ], [ 11, 0, '0', 'e5' ] ]; $t= "Select all values"; my $query= "select * from dbd_mysql_t51bind_type_guessing"; ok $retref = $dbh->selectall_arrayref($query), $t; for my $i (0 .. $#$res) { if ($i == 6) { is($retref->[$i][1], undef, "$i: nn undefined as expected"); is($retref->[$i][2], undef, "$i: dd undefined as expected"); is($retref->[$i][3], undef, "$i: str undefined as expected"); } else { cmp_ok $retref->[$i][1], '==', $res->[$i][1], "test: " . "$retref->[$i][1], '==', $res->[$i][1]"; cmp_ok $retref->[$i][2], 'eq', $res->[$i][2], "test: " . "$retref->[$i][2], '==', $res->[$i][2]"; cmp_ok $retref->[$i][3], 'eq', $res->[$i][3], "test: " . "$retref->[$i][2], '==', $res->[$i][2]"; } } my $sth3; $t = "Prepare limit statement"; ok $sth3= $dbh->prepare("select * from dbd_mysql_t51bind_type_guessing limit ?"), $t; $val = 1; $t = "select with limit $val statement"; ok $rows= $sth3->execute($val), $t; $val = ' 1'; $t = "select with limit $val statement"; ok $rows= $sth3->execute($val), $t; $sth3->finish(); ok $dbh->do("DROP TABLE dbd_mysql_t51bind_type_guessing"); ok $dbh->disconnect; ��92ssl_optional.t��0000644��00000002744�15125143222�0007616 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require "lib.pl"; my $dbh = DbiTestConnect($test_dsn, $test_user, $test_password, { PrintError => 0, RaiseError => 1 }); my $have_ssl = eval { $dbh->selectrow_hashref("SHOW VARIABLES WHERE Variable_name = 'have_ssl'") }; $dbh->disconnect(); plan skip_all => 'Server supports SSL connections, cannot test fallback to plain text' if $have_ssl and $have_ssl->{Value} eq 'YES'; # `have_ssl` has been deprecated in 8.0.26 and removed in 8.4.0... plan skip_all => 'Server might support SSL connections, cannot test false-positive enforcement' if not $have_ssl; plan tests => 2; $dbh = DBI->connect($test_dsn, $test_user, $test_password, { PrintError => 1, RaiseError => 0, mysql_ssl => 1, mysql_ssl_optional => 1 }); ok(defined $dbh, 'DBD::mysql supports mysql_ssl_optional=1 and connect via plain text protocol when SSL is not supported by server') or diag('Error code: ' . ($DBI::err \|\| 'none') . "\n" . 'Error message: ' . ($DBI::errstr \|\| 'unknown')); $dbh = DBI->connect($test_dsn, $test_user, $test_password, { PrintError => 1, RaiseError => 0, mysql_ssl => 1, mysql_ssl_optional => 1, mysql_ssl_ca_file => "" }); ok(defined $dbh, 'DBD::mysql supports mysql_ssl_optional=1 and connect via plain text protocol when SSL is not supported by server even with mysql_ssl_ca_file') or diag('Error code: ' . ($DBI::err \|\| 'none') . "\n" . 'Error message: ' . ($DBI::errstr \|\| 'unknown')); ��65segfault.t��0000644��00000002176�15125143222�0006721 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use DBI::Const::GetInfoType; use lib 't', '.'; require 'lib.pl'; $\|= 1; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { mysql_auto_reconnect => 1, RaiseError => 1, PrintError => 1, AutoCommit => 1 }); }; if ($@) { plan skip_all => "no database connection"; } my $dbh2; eval {$dbh2= DBI->connect($test_dsn, $test_user, $test_password);}; if ($@) { plan skip_all => "no database connection"; } plan tests => 5; ok(defined $dbh, "Handle 1 Connected to database"); ok(defined $dbh2, "Handle 2 Connected to database"); #kill first db connection to trigger an auto reconnect ok ($dbh2->do('kill ' . $dbh->{'mysql_thread_id'})); #insert a temporary delay, try uncommenting this if it's not seg-faulting at first, # one of my initial tests without this delay didn't seg fault sleep 1; #ping first dbh handle to trigger auto-reconnect $dbh->ping; ok ($dbh); ok ($dbh2); ��rt83494-quotes-comments.t��0000644��00000001632�15125143222�0011132 0��ustar�00��# Test special characters inside comments # http://bugs.debian.org/311040 # http://bugs.mysql.com/27625 use strict; use warnings; use DBI; use Test::More; use vars qw($test_dsn $test_user $test_password $state); require "t/lib.pl"; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 0, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } my %tests = ( questionmark => " -- Does the question mark at the end confuse DBI::MySQL?\nselect ?", quote => " -- 'Tis the quote that confuses DBI::MySQL\nSELECT ?" ); for my $test ( sort keys %tests ) { my $sth = $dbh->prepare($tests{$test}); ok($sth, 'created statement hande'); ok($sth->execute(), 'executing'); ok($sth->{ParamValues}, 'values'); ok($sth->finish(), 'finish'); } ok ($dbh->disconnect(), 'disconnecting from dbh'); done_testing; ��17quote.t��0000644��00000002005�15125143222�0006230 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use vars qw($test_dsn $test_user $test_password); use lib '.', 't'; require 'lib.pl'; my $dbh; eval {$dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1}) or ServerError() ;}; if ($@) { plan skip_all => "no database connection"; } my @sqlmodes = (qw/ empty ANSI_QUOTES NO_BACKSLASH_ESCAPES/); my @words = (qw/ foo foo'bar foo\bar /); my @results_empty = (qw/ 'foo' 'foo\'bar' 'foo\\\\bar'/); my @results_ansi = (qw/ 'foo' 'foo\'bar' 'foo\\\\bar'/); my @results_no_backlslash = (qw/ 'foo' 'foo''bar' 'foo\\bar'/); my @results = (\@results_empty, \@results_ansi, \@results_no_backlslash); plan tests => (@sqlmodes * @words * 2 + 1); while (my ($i, $sqlmode) = each @sqlmodes) { $dbh->do("SET sql_mode=?", undef, $sqlmode eq "empty" ? "" : $sqlmode); for my $j (0..@words-1) { ok $dbh->quote($words[$j]); cmp_ok($dbh->quote($words[$j]), "eq", $results[$i][$j], "$sqlmode $words[$j]"); } } ok $dbh->disconnect; ��rt75353-innodb-lock-timeout.t��0000644��00000005360�15125143222�0011647 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use vars qw($test_dsn $test_user $test_password); require "t/lib.pl"; my $dbh1 = eval { DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 0 }) }; plan skip_all => "no database connection" if $@ or not $dbh1; my $dbh2 = eval { DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 0 }) }; plan skip_all => "no database connection" if $@ or not $dbh2; my @ilwtenabled = $dbh1->selectrow_array("SHOW VARIABLES LIKE 'innodb_lock_wait_timeout'"); if (!@ilwtenabled) { plan skip_all => 'innodb_lock_wait_timeout not available'; } my $have_innodb = 0; if (!MinimumVersion($dbh1, '5.6')) { my $dummy; ($dummy,$have_innodb)= $dbh1->selectrow_array("SHOW VARIABLES LIKE 'have_innodb'") or DbiError($dbh1->err, $dbh1->errstr); } else { my $engines = $dbh1->selectall_arrayref('SHOW ENGINES'); if (!$engines) { DbiError($dbh1->err, $dbh1->errstr); } else { STORAGE_ENGINE: for my $engine (@$engines) { next STORAGE_ENGINE if lc $engine->[0] ne 'innodb'; next STORAGE_ENGINE if lc $engine->[1] eq 'no'; $have_innodb = 1; } } } if (!$have_innodb) { plan skip_all => "Server doesn't support InnoDB, needed for testing innodb_lock_wait_timeout"; } eval { $dbh2->{PrintError} = 0; $dbh2->do("SET innodb_lock_wait_timeout=1"); $dbh2->{PrintError} = 1; 1; } or do { $dbh1->disconnect(); $dbh2->disconnect(); plan skip_all => "innodb_lock_wait_timeout is not modifyable on this version of MySQL"; }; ok $dbh1->do("DROP TABLE IF EXISTS dbd_mysql_rt75353_innodb_lock_timeout"), "drop table if exists dbd_mysql_rt75353_innodb_lock_timeout"; ok $dbh1->do("CREATE TABLE dbd_mysql_rt75353_innodb_lock_timeout(id INT PRIMARY KEY) ENGINE=INNODB"), "create table dbd_mysql_rt75353_innodb_lock_timeout"; ok $dbh1->do("INSERT INTO dbd_mysql_rt75353_innodb_lock_timeout VALUES(1)"), "dbh1: acquire a row lock on table dbd_mysql_rt75353_innodb_lock_timeout"; my $error_handler_called = 0; $dbh2->{HandleError} = sub { $error_handler_called = 1; die $_[0]; }; eval { $dbh2->selectcol_arrayref("SELECT id FROM dbd_mysql_rt75353_innodb_lock_timeout FOR UPDATE") }; my $error_message = $@; $dbh2->{HandleError} = undef; ok $error_message, "dbh2: acquiring same lock as dbh1 on table dbd_mysql_rt75353_innodb_lock_timeout failed"; like $error_message, qr/Lock wait timeout exceeded; try restarting transaction/, "dbh2: error message for acquiring lock is 'Lock wait timeout exceeded'"; ok $error_handler_called, "dbh2: error handler code ref was called"; $dbh2->disconnect(); ok $dbh1->do("DROP TABLE dbd_mysql_rt75353_innodb_lock_timeout"), "drop table dbd_mysql_rt75353_innodb_lock_timeout"; $dbh1->disconnect(); done_testing; ��53comment.t��0000644��00000003520�15125143222�0006540 0��ustar�00��use strict; use warnings; use DBI; use DBI::Const::GetInfoType; use Test::More; use lib 't', '.'; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password); my $dbh; eval { $dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0, mysql_bind_comment_placeholders => 1,} ); }; if ($@) { plan skip_all => "no database connection"; } my $create= <<"EOTABLE"; CREATE TEMPORARY TABLE dbd_mysql_53 ( id bigint unsigned not null default 0 ) EOTABLE ok $dbh->do($create), "creating table"; my $statement= "insert into dbd_mysql_53 (id) values (?)"; my $sth; ok $sth= $dbh->prepare($statement); my $rows; ok $rows= $sth->execute('1'); cmp_ok $rows, '==', 1; $sth->finish(); my $retrow; if ( $test_dsn =~ m/mysql_server_prepare=1/ ) { # server_prepare can't bind placeholder on comment. ok 1; ok 2; } else { $statement= <<EOSTMT; SELECT id FROM dbd_mysql_53 -- this comment has ? in the text WHERE id = ? EOSTMT $retrow= $dbh->selectrow_arrayref($statement, {}, 'hey', 1); cmp_ok $retrow->[0], '==', 1; $statement= "SELECT id FROM dbd_mysql_53 /* Some value here ? / WHERE id = ?"; $retrow= $dbh->selectrow_arrayref($statement, {}, "hello", 1); cmp_ok $retrow->[0], '==', 1; } $statement= "SELECT id FROM dbd_mysql_53 WHERE id = ? "; my $comment = "/ it's/a_directory/does\ this\ work/bug? /"; $statement= $statement . $comment; for (0 .. 9) { $retrow= $dbh->selectrow_arrayref($statement, {}, 1); cmp_ok $retrow->[0], '==', 1; } $comment = "/ $0 /"; for (0 .. 9) { $retrow= $dbh->selectrow_arrayref($statement . $comment, {}, 1); cmp_ok $retrow->[0], '==', 1; } ok $dbh->disconnect; done_testing; ��52comment.t��0000644��00000003722�15125143222�0006543 0��ustar�00��use strict; use warnings; use DBI; use DBI::Const::GetInfoType; use Test::More; use lib 't', '.'; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password); my $dbh; eval { $dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0, } ); }; if ($@) { plan skip_all => plan skip_all => "no database connection"; } plan tests => 30; ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t52comment"), "drop table if exists dbd_mysql_t52comment"; my $create= <<"EOTABLE"; create table dbd_mysql_t52comment ( id bigint unsigned not null default 0 ) EOTABLE ok $dbh->do($create), "creating table"; my $statement= "insert into dbd_mysql_t52comment (id) values (?)"; my $sth; ok $sth= $dbh->prepare($statement); my $rows; ok $rows= $sth->execute('1'); cmp_ok $rows, '==', 1; $sth->finish(); $statement= <<EOSTMT; SELECT id FROM dbd_mysql_t52comment -- it's a bug? WHERE id = ? EOSTMT my $retrow= $dbh->selectrow_arrayref($statement, {}, 1); cmp_ok $retrow->[0], '==', 1; $statement= "SELECT id FROM dbd_mysql_t52comment / it's a bug? / WHERE id = ?"; $retrow= $dbh->selectrow_arrayref($statement, {}, 1); cmp_ok $retrow->[0], '==', 1; $statement= "SELECT id FROM dbd_mysql_t52comment WHERE id = ? / it's a bug? /"; $retrow= $dbh->selectrow_arrayref($statement, {}, 1); cmp_ok $retrow->[0], '==', 1; $statement= "SELECT id FROM dbd_mysql_t52comment WHERE id = ? "; my $comment = "/ it's/a_directory/does\ this\ work/bug? /"; for (0 .. 9) { $retrow= $dbh->selectrow_arrayref($statement . $comment, {}, 1); cmp_ok $retrow->[0], '==', 1; } $comment = "/ $0 /"; for (0 .. 9) { $retrow= $dbh->selectrow_arrayref($statement . $comment, {}, 1); cmp_ok $retrow->[0], '==', 1; } ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t52comment"), "drop table if exists dbd_mysql_t52comment"; ok $dbh->disconnect; ��rt88006-bit-prepare.t��0000644��00000007240�15125143222�0010174 0��ustar�00��use strict; use warnings; use vars qw($test_dsn $test_user $test_password); use DBI; use Test::More; use lib 't', '.'; require 'lib.pl'; for my $scenario (qw(prepare noprepare)) { my $dbh; my $sth; my $dsn = $test_dsn; $dsn .= ';mysql_server_prepare=1;mysql_server_prepare_disable_fallback=1' if $scenario eq 'prepare'; eval {$dbh = DBI->connect($dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1})}; if ($@) { plan skip_all => "no database connection"; } if ($dbh->{mysql_serverversion} < 50008) { plan skip_all => "Servers < 5.0.8 do not support b'' syntax"; } if ($dbh->{mysql_serverversion} < 50026) { plan skip_all => "Servers < 5.0.26 do not support BIN() for BIT values"; } my $create = <<EOT; CREATE TEMPORARY TABLE `dbd_mysql_rt88006_bit_prep` ( `id` bigint(20) NOT NULL auto_increment, `flags` bit(40) NOT NULL, PRIMARY KEY (`id`), KEY `flags` (`flags`) ) EOT ok $dbh->do($create),"create table for $scenario"; ok $dbh->do("INSERT INTO dbd_mysql_rt88006_bit_prep (id, flags) VALUES (1, b'10'), (2, b'1'), (3, b'1111011111101111101101111111101111111101')"); ok $sth = $dbh->prepare("INSERT INTO dbd_mysql_rt88006_bit_prep (id, flags) VALUES (?, ?)"); ok $sth->bind_param(1, 4, DBI::SQL_INTEGER); ok $sth->bind_param(2, pack("B", '1110000000000000011101100000000011111101'), DBI::SQL_BINARY); ok $sth->execute() or die("Execute failed: ".$DBI::errstr); ok $sth->finish; ok $sth = $dbh->prepare("SELECT id,flags FROM dbd_mysql_rt88006_bit_prep WHERE id = 1"); ok $sth->execute() or die("Execute failed: ".$DBI::errstr); ok (my $r = $sth->fetchrow_hashref(), "fetchrow_hashref for $scenario"); is ($r->{id}, 1, 'id test contents'); is (unpack("B", $r->{flags}), '0000000000000000000000000000000000000010', 'flags has contents'); ok $sth->finish; ok $sth = $dbh->prepare("SELECT id,flags FROM dbd_mysql_rt88006_bit_prep WHERE id = 3"); ok $sth->execute() or die("Execute failed: ".$DBI::errstr); ok ($r = $sth->fetchrow_hashref(), "fetchrow_hashref for $scenario with more then 32 bits"); is ($r->{id}, 3, 'id test contents'); is (unpack("B", $r->{flags}), '1111011111101111101101111111101111111101', 'flags has contents'); ok $sth->finish; ok $sth = $dbh->prepare("SELECT id,flags FROM dbd_mysql_rt88006_bit_prep WHERE id = 4"); ok $sth->execute() or die("Execute failed: ".$DBI::errstr); ok ($r = $sth->fetchrow_hashref(), "fetchrow_hashref for $scenario with binary insert"); is ($r->{id}, 4, 'id test contents'); is (unpack("B", $r->{flags}), '1110000000000000011101100000000011111101', 'flags has contents'); ok $sth->finish; ok $sth = $dbh->prepare("SELECT id,BIN(flags) FROM dbd_mysql_rt88006_bit_prep WHERE ID =1"); ok $sth->execute() or die("Execute failed: ".$DBI::errstr); ok ($r = $sth->fetchrow_hashref(), "fetchrow_hashref for $scenario with BIN()"); is ($r->{id}, 1, 'id test contents'); is ($r->{'BIN(flags)'}, '10', 'flags has contents'); ok $sth = $dbh->prepare("SELECT id,BIN(flags) FROM dbd_mysql_rt88006_bit_prep WHERE ID =3"); ok $sth->execute() or die("Execute failed: ".$DBI::errstr); ok ($r = $sth->fetchrow_hashref(), "fetchrow_hashref for $scenario with BIN() and more then 32 bits"); is ($r->{id}, 3, 'id test contents'); is ($r->{'BIN(flags)'}, '1111011111101111101101111111101111111101', 'flags has contents'); ok $sth = $dbh->prepare("SELECT id,BIN(flags) FROM dbd_mysql_rt88006_bit_prep WHERE ID =4"); ok $sth->execute() or die("Execute failed: ".$DBI::errstr); ok ($r = $sth->fetchrow_hashref(), "fetchrow_hashref for $scenario with BIN() and with binary insert"); is ($r->{id}, 4, 'id test contents'); is ($r->{'BIN(flags)'}, '1110000000000000011101100000000011111101', 'flags has contents'); ok $sth->finish; ok $dbh->disconnect; } done_testing; ��lib.pl��0000644��00000007623�15125143222�0005654 0��ustar�00��use strict; use warnings; use Test::More; use DBI::Const::GetInfoType; use vars qw($mdriver $dbdriver $childPid $test_dsn $test_user $test_password); $\| = 1; # flush stdout asap to keep in sync with stderr # # Driver names; EDIT THIS! # $mdriver = 'mysql'; $dbdriver = $mdriver; # $dbdriver is usually just the same as $mdriver. # The exception is DBD::pNET where we have to # to separate between local driver (pNET) and # the remote driver ($dbdriver) # # DSN being used; do not edit this, edit "$dbdriver.dbtest" instead # $::COL_NULLABLE = 1; $::COL_KEY = 2; my $file; if (-f ($file = "t/$dbdriver.dbtest") \|\| -f ($file = "$dbdriver.dbtest") \|\| -f ($file = "../tests/$dbdriver.dbtest") \|\| -f ($file = "tests/$dbdriver.dbtest")) { eval { require $file; }; if ($@) { print STDERR "Cannot execute $file: $@.\n"; print "1..0\n"; exit 0; } $::test_dsn = $::test_dsn \|\| $ENV{'DBI_DSN'} \|\| 'DBI:mysql:database=test'; $::test_user = $::test_user\|\| $ENV{'DBI_USER'} \|\| ''; $::test_password = $::test_password \|\| $ENV{'DBI_PASS'} \|\| ''; } if (-f ($file = "t/$mdriver.mtest") \|\| -f ($file = "$mdriver.mtest") \|\| -f ($file = "../tests/$mdriver.mtest") \|\| -f ($file = "tests/$mdriver.mtest")) { eval { require $file; }; if ($@) { print STDERR "Cannot execute $file: $@.\n"; print "1..0\n"; exit 0; } } sub DbiTestConnect { return (eval { DBI->connect(@_) } or do { my $err; if ( $@ ) { $err = $@; $err =~ s/ at \S+ line \d+\s$//; } if ( not $err ) { $err = $DBI::errstr; $err = "unknown error" unless $err; my $user = $_[1]; my $dsn = $_[0]; $dsn =~ s/^DBI:mysql://; $err = "DBI connect('$dsn','$user',...) failed: $err"; } if ( $ENV{CONNECTION_TESTING} ) { BAIL_OUT "no database connection: $err"; } else { plan skip_all => "no database connection: $err"; } }); } # # Print a DBI error message # # TODO - This is on the chopping block sub DbiError ($$) { my ($rc, $err) = @_; $rc \|\|= 0; $err \|\|= ''; $::numTests \|\|= 0; print "Test $::numTests: DBI error $rc, $err\n"; } sub connection_id { my $dbh = shift; return 0 unless $dbh; # Paul DuBois says the following is more reliable than # $dbh->{'mysql_thread_id'}; my @row = $dbh->selectrow_array("SELECT CONNECTION_ID()"); return $row[0]; } # nice function I saw in DBD::Pg test code sub byte_string { my $ret = join( "\|" ,unpack( "C" ,$_[0] ) ); return $ret; } sub SQL_VARCHAR { 12 }; sub SQL_INTEGER { 4 }; =item CheckRoutinePerms() Check if the current user of the DBH has permissions to create/drop procedures if (!CheckRoutinePerms($dbh)) { plan skip_all => "Your test user does not have ALTER_ROUTINE privileges."; } =cut sub CheckRoutinePerms { my $dbh = shift @_; # check for necessary privs local $dbh->{PrintError} = 0; eval { $dbh->do('DROP PROCEDURE IF EXISTS testproc') }; return if $@ =~ qr/alter routine command denied to user/; return 1; }; =item MinimumVersion() Check to see if the database where the test run against is of a certain minimum version if (!MinimumVersion($dbh, '5.0')) { plan skip_all => "You must have MySQL version 5.0 and greater for this test to run"; } =cut sub MinimumVersion { my $dbh = shift @_; my $version = shift @_; my ($major, $minor) = split (/\./, $version); if ( $dbh->get_info($GetInfoType{SQL_DBMS_VER}) =~ /(^\d+)\.(\d+)\./ ) { # major version higher than requested return 1 if $1 > $major; # major version too low return if $1 < $major; # check minor version return 1 if $2 >= $minor; } return; } 1; ��32insert_error.t��0000644��00000001605�15125143222�0007612 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use lib '.', 't'; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1})}; if ($@) { plan skip_all => "no database connection"; } plan tests => 9; ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t32"); my $create = <<EOT; CREATE TABLE dbd_mysql_t32 ( id INT(3) PRIMARY KEY NOT NULL, name VARCHAR(64)) EOT ok $dbh->do($create); my $query = "INSERT INTO dbd_mysql_t32 (id, name) VALUES (?,?)"; ok (my $sth = $dbh->prepare($query)); ok $sth->execute(1, "Jocken"); $sth->{PrintError} = 0; eval {$sth->execute(1, "Jochen")}; ok defined($@), 'fails with duplicate entry'; $sth->{PrintError} = 1; ok $sth->execute(2, "Jochen"); ok $sth->finish; ok $dbh->do("DROP TABLE dbd_mysql_t32"); ok $dbh->disconnect(); ��01caching_sha2_prime.t��0000644��00000001337�15125143222�0010600 0��ustar�00��use strict; use warnings; use Test::More ; use DBI; $\|= 1; use vars qw($test_user $test_password $test_db $test_dsn); use lib 't', '.'; require 'lib.pl'; # remove database from DSN $test_dsn =~ s/^DBI:mysql:([^:]+)(:?)/DBI:mysql:$2/; # This should result in a cached sha2 password entry # The result is that subsequent connections don't need # TLS or the RSA pubkey. $test_dsn .= ';mysql_ssl=1;mysql_get_server_pubkey=1'; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { diag $@; plan skip_all => "no database connection"; } plan tests => 2; ok defined $dbh, "Connected to database"; ok $dbh->disconnect(); ��40bit.t��0000644��00000002403�15125143222�0005647 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use vars qw($test_dsn $test_user $test_password); use lib '.', 't'; require 'lib.pl'; sub VerifyBit ($) { } my $dbh; my $charset= 'DEFAULT CHARSET=utf8'; eval {$dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1}) or ServerError() ;}; if ($@) { plan skip_all => "no database connection"; } if ($dbh->{mysql_serverversion} < 50008) { plan skip_all => "Servers < 5.0.8 do not support b'' syntax"; } plan tests => 15; ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_b1"), "Drop table if exists dbd_mysql_b1"; ok( $dbh->do('CREATE TABLE dbd_mysql_b1 (b BIT(8))') ); ok ($dbh->do("insert into dbd_mysql_b1 set b = b'11111111'")); ok ($dbh->do("insert into dbd_mysql_b1 set b = b'1010'")); ok ($dbh->do("insert into dbd_mysql_b1 set b = b'0101'")); ok (my $sth = $dbh->prepare("select BIN(b+0) FROM dbd_mysql_b1")); ok ($sth->execute); ok (my $result = $sth->fetchall_arrayref); ok defined($result), "result returned defined"; is $result->[0][0], 11111111, "should be 11111111"; is $result->[1][0], 1010, "should be 1010"; is $result->[2][0], 101, "should be 101"; ok ($sth->finish); ok $dbh->do("DROP TABLE dbd_mysql_b1"), "Drop table dbd_mysql_b1"; ok $dbh->disconnect; ��92ssl_backronym_vulnerability.t��0000644��00000002732�15125143222�0012724 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require "lib.pl"; my $dbh = DbiTestConnect($test_dsn, $test_user, $test_password, { PrintError => 0, RaiseError => 1 }); my $have_ssl = eval { $dbh->selectrow_hashref("SHOW VARIABLES WHERE Variable_name = 'have_ssl'") }; $dbh->disconnect(); plan skip_all => 'Server supports SSL connections, cannot test false-positive enforcement' if $have_ssl and $have_ssl->{Value} eq 'YES'; # `have_ssl` has been deprecated in 8.0.26 and removed in 8.4.0... plan skip_all => 'Server might support SSL connections, cannot test false-positive enforcement' if not $have_ssl; plan tests => 4; $dbh = DBI->connect($test_dsn, $test_user, $test_password, { PrintError => 0, RaiseError => 0, mysql_ssl => 1 }); ok(!defined $dbh, 'DBD::mysql refused connection to non-SSL server with mysql_ssl=1 and correct user and password'); is($DBI::err, 2026, 'DBD::mysql error message is SSL related') or diag('Error message: ' . ($DBI::errstr \|\| 'unknown')); $dbh = DBI->connect($test_dsn, $test_user, $test_password, { PrintError => 0, RaiseError => 0, mysql_ssl => 1, mysql_ssl_verify_server_cert => 1, mysql_ssl_ca_file => "" }); ok(!defined $dbh, 'DBD::mysql refused connection to non-SSL server with mysql_ssl=1, mysql_ssl_verify_server_cert=1 and correct user and password'); is($DBI::err, 2026, 'DBD::mysql error message is SSL related') or diag('Error message: ' . ($DBI::errstr \|\| 'unknown')); ��80procs.t��0000644��00000005365�15125143222�0006235 0��ustar�00��use strict; use warnings; use lib 't', '.'; require 'lib.pl'; use DBI; use Test::More; use vars qw($test_dsn $test_user $test_password); my ($row, $vers, $test_procs, $dbh, $sth); eval {$dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1})}; if ($@) { plan skip_all => "no database connection"; } # # DROP/CREATE PROCEDURE will give syntax error # for versions < 5.0 # if ($dbh->{mysql_serverversion} < 50000) { plan skip_all => "You must have MySQL version 5.0 and greater for this test to run"; } if (!CheckRoutinePerms($dbh)) { plan skip_all => "Your test user does not have ALTER_ROUTINE privileges."; } plan tests => 31; $dbh->disconnect(); ok ($dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1})); ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t80procs"); my $drop_proc= "DROP PROCEDURE IF EXISTS dbd_mysql_t80testproc"; ok ($dbh->do($drop_proc), "DROP PROCEDURE") or diag "errstr=$DBI::errstr, err=$DBI::err"; my $proc_create = <<EOPROC; create procedure dbd_mysql_t80testproc() deterministic begin declare a,b,c,d int; set a=1; set b=2; set c=3; set d=4; select a, b, c, d; select d, c, b, a; select b, a, c, d; select c, b, d, a; end EOPROC ok $dbh->do($proc_create); my $proc_call = 'CALL dbd_mysql_t80testproc()'; ok $dbh->do($proc_call); my $proc_select = 'SELECT @a'; ok ($sth = $dbh->prepare($proc_select)); ok $sth->execute(); ok $sth->finish; ok $dbh->do("DROP PROCEDURE dbd_mysql_t80testproc"); ok $dbh->do("drop procedure if exists test_multi_sets"); $proc_create = <<EOT; create procedure test_multi_sets () deterministic begin select user() as first_col; select user() as first_col, now() as second_col; select user() as first_col, now() as second_col, now() as third_col; end EOT ok $dbh->do($proc_create); ok ($sth = $dbh->prepare("call test_multi_sets()")); ok $sth->execute(); is $sth->{NUM_OF_FIELDS}, 1, "num_of_fields == 1"; my $resultset; ok ($resultset = $sth->fetchrow_arrayref()); ok defined $resultset; is @$resultset, 1, "1 row in resultset"; undef $resultset; ok $sth->more_results(); is $sth->{NUM_OF_FIELDS}, 2, "NUM_OF_FIELDS == 2"; ok ($resultset= $sth->fetchrow_arrayref()); ok defined $resultset; is @$resultset, 2, "2 rows in resultset"; undef $resultset; ok $sth->more_results(); is $sth->{NUM_OF_FIELDS}, 3, "NUM_OF_FIELDS == 3"; ok ($resultset= $sth->fetchrow_arrayref()); ok defined $resultset; is @$resultset, 3, "3 Rows in resultset"; ok $sth->more_results(); is $sth->{NUM_OF_FIELDS}, 0, "NUM_OF_FIELDS == 0"; + local $SIG{__WARN__} = sub { die @_ }; ok $sth->finish; ok $dbh->disconnect(); ��76multi_statement.t��0000644��00000005552�15125143222�0010330 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use lib 't', '.'; require 'lib.pl'; $\|= 1; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0, mysql_multi_statements => 1 });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 26; ok (defined $dbh, "Connected to database with multi statement support"); $dbh->{mysql_server_prepare}= 0; SKIP: { skip "Server doesn't support multi statements", 25 if $dbh->{mysql_clientversion} < 40101 or $dbh->{mysql_serverversion} < 40101; skip "Server has deadlock bug 16581", 25 if $dbh->{mysql_clientversion} < 50025 or ($dbh->{mysql_serverversion} >= 50100 and $dbh->{mysql_serverversion} < 50112); ok($dbh->do("SET SQL_MODE=''"),"init connection SQL_MODE non strict"); ok($dbh->do("DROP TABLE IF EXISTS dbd_mysql_t76multi"), "clean up"); ok($dbh->do("CREATE TABLE dbd_mysql_t76multi (a INT)"), "create table"); ok($dbh->do("INSERT INTO dbd_mysql_t76multi VALUES (1); INSERT INTO dbd_mysql_t76multi VALUES (2);"), "2 inserts"); # Check that a second do() doesn't fail with an 'Out of sync' error ok($dbh->do("INSERT INTO dbd_mysql_t76multi VALUES (3); INSERT INTO dbd_mysql_t76multi VALUES (4);"), "2 more inserts"); # Check that more_results works for non-SELECT results too my $sth; ok($sth = $dbh->prepare("UPDATE dbd_mysql_t76multi SET a=5 WHERE a=1; UPDATE dbd_mysql_t76multi SET a='6-' WHERE a<4")); ok($sth->execute(), "Execute updates"); is($sth->rows, 1, "First update affected 1 row"); is($sth->{mysql_warning_count}, 0, "First update had no warnings"); ok($sth->{Active}, "Statement handle is Active"); ok($sth->more_results()); is($sth->rows, 2, "Second update affected 2 rows"); is($sth->{mysql_warning_count}, 2, "Second update had 2 warnings"); ok(not $sth->more_results()); ok($sth->finish()); # Now run it again without calling more_results(). ok($sth->execute(), "Execute updates again"); ok($sth->finish()); # Check that do() doesn't fail with an 'Out of sync' error is($dbh->do("DELETE FROM dbd_mysql_t76multi"), 4, "Delete all rows"); # Test that do() reports errors from all result sets $dbh->{RaiseError} = $dbh->{PrintError} = 0; ok(!$dbh->do("INSERT INTO dbd_mysql_t76multi VALUES (1); INSERT INTO bad_dbd_mysql_t76multi VALUES (2);"), "do() reports errors"); # Test that execute() reports errors from only the first result set ok($sth = $dbh->prepare("UPDATE dbd_mysql_t76multi SET a=2; UPDATE bad_dbd_mysql_t76multi SET a=3")); ok($sth->execute(), "Execute updates"); ok(!$sth->err(), "Err was not set after execute"); ok(!$sth->more_results()); ok($sth->err(), "Err was set after more_results"); ok $dbh->do("DROP TABLE dbd_mysql_t76multi"); }; $dbh->disconnect(); ��40types.t��0000644��00000006677�15125143222�0006256 0��ustar�00��use strict; use warnings; use B qw(svref_2object SVf_IOK SVf_NOK SVf_POK SVf_IVisUV); use Test::More; use DBI; use DBI::Const::GetInfoType; use lib '.', 't'; require 'lib.pl'; $\|= 1; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 40; ok(defined $dbh, "Connected to database"); ok($dbh->do(qq{DROP TABLE IF EXISTS t1}), "making slate clean"); ok($dbh->do(qq{CREATE TABLE t1 (num INT)}), "creating table"); ok($dbh->do(qq{INSERT INTO t1 VALUES (100)}), "loading data"); my ($val) = $dbh->selectrow_array("SELECT FROM t1"); is($val, 100); my $sv = svref_2object(\$val); ok($sv->FLAGS & SVf_IOK, "scalar is integer"); ok(!($sv->FLAGS & (SVf_IVisUV\|SVf_NOK\|SVf_POK)), "scalar is not unsigned intger or double or string"); ok($dbh->do(qq{DROP TABLE t1}), "cleaning up"); ok($dbh->do(qq{CREATE TABLE t1 (num VARCHAR(10))}), "creating table"); ok($dbh->do(qq{INSERT INTO t1 VALUES ('string')}), "loading data"); ($val) = $dbh->selectrow_array("SELECT * FROM t1"); is($val, "string"); $sv = svref_2object(\$val); ok($sv->FLAGS & SVf_POK, "scalar is string"); ok(!($sv->FLAGS & (SVf_IOK\|SVf_NOK)), "scalar is not intger or double"); ok($dbh->do(qq{DROP TABLE t1}), "cleaning up"); SKIP: { skip "New Data types not supported by server", 26 if !MinimumVersion($dbh, '5.0'); ok($dbh->do(qq{CREATE TABLE t1 (d DECIMAL(5,2))}), "creating table"); my $sth= $dbh->prepare("SELECT * FROM t1 WHERE 1 = 0"); ok($sth->execute(), "getting table information"); is_deeply($sth->{TYPE}, [ 3 ], "checking column type"); ok($sth->finish); ok($dbh->do(qq{DROP TABLE t1}), "cleaning up"); # # Bug #23936: bind_param() doesn't work with SQL_DOUBLE datatype # Bug #24256: Another failure in bind_param() with SQL_DOUBLE datatype # ok($dbh->do(qq{CREATE TABLE t1 (num DOUBLE)}), "creating table"); $sth= $dbh->prepare("INSERT INTO t1 VALUES (?)"); ok($sth->bind_param(1, 2.1, DBI::SQL_DOUBLE), "binding parameter"); ok($sth->execute(), "inserting data"); ok($sth->finish); ok($sth->bind_param(1, -1, DBI::SQL_DOUBLE), "binding parameter"); ok($sth->execute(), "inserting data"); ok($sth->finish); my $ret = $dbh->selectall_arrayref("SELECT * FROM t1"); is_deeply($ret, [ [2.1], [-1] ]); $sv = svref_2object(\$ret->[0]->[0]); ok($sv->FLAGS & SVf_NOK, "scalar is double"); ok(!($sv->FLAGS & (SVf_IOK\|SVf_POK)), "scalar is not integer or string"); $sv = svref_2object(\$ret->[1]->[0]); ok($sv->FLAGS & SVf_NOK, "scalar is double"); ok(!($sv->FLAGS & (SVf_IOK\|SVf_POK)), "scalar is not integer or string"); ok($dbh->do(qq{DROP TABLE t1}), "cleaning up"); # # [rt.cpan.org #19212] Mysql Unsigned Integer Fields # ok($dbh->do(qq{CREATE TABLE t1 (num INT UNSIGNED)}), "creating table"); ok($dbh->do(qq{INSERT INTO t1 VALUES (0),(4294967295)}), "loading data"); $ret = $dbh->selectall_arrayref("SELECT * FROM t1"); is_deeply($ret, [ [0], [4294967295] ]); $sv = svref_2object(\$ret->[0]->[0]); ok($sv->FLAGS & (SVf_IOK\|SVf_IVisUV), "scalar is unsigned integer"); ok(!($sv->FLAGS & (SVf_NOK\|SVf_POK)), "scalar is not double or string"); $sv = svref_2object(\$ret->[1]->[0]); ok($sv->FLAGS & (SVf_IOK\|SVf_IVisUV), "scalar is unsigned integer"); ok(!($sv->FLAGS & (SVf_NOK\|SVf_POK)), "scalar is not double or string"); ok($dbh->do(qq{DROP TABLE t1}), "cleaning up"); }; $dbh->disconnect(); ��40server_prepare.t��0000644��00000006474�15125143222�0010131 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use lib 't', '.'; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password); $\|= 1; $test_dsn.= ";mysql_server_prepare=1;mysql_server_prepare_disable_fallback=1"; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } if ($dbh->{mysql_clientversion} < 40103 or $dbh->{mysql_serverversion} < 40103) { plan skip_all => "You must have MySQL version 4.1.3 and greater for this test to run"; } plan tests => 31; ok(defined $dbh, "connecting"); ok($dbh->do(qq{DROP TABLE IF EXISTS dbd_mysql_t40serverprepare1}), "making slate clean"); # # Bug #20559: Program crashes when using server-side prepare # ok($dbh->do(qq{CREATE TABLE dbd_mysql_t40serverprepare1 (id INT, num DOUBLE)}), "creating table"); my $sth; ok($sth= $dbh->prepare(qq{INSERT INTO dbd_mysql_t40serverprepare1 VALUES (?,?),(?,?)}), "loading data"); ok($sth->execute(1, 3.0, 2, -4.5)); ok ($sth= $dbh->prepare("SELECT num FROM dbd_mysql_t40serverprepare1 WHERE id = ? FOR UPDATE")); ok ($sth->bind_param(1, 1), "binding parameter"); ok ($sth->execute(), "fetching data"); is_deeply($sth->fetchall_arrayref({}), [ { 'num' => '3' } ]); ok ($sth->finish); ok ($dbh->do(qq{DROP TABLE dbd_mysql_t40serverprepare1}), "cleaning up"); # # Bug #42723: Binding server side integer parameters results in corrupt data # ok($dbh->do(qq{DROP TABLE IF EXISTS dbd_mysql_t40serverprepare2}), "making slate clean"); ok($dbh->do(q{CREATE TABLE `dbd_mysql_t40serverprepare2` (`i` int,`si` smallint,`ti` tinyint,`bi` bigint)}), "creating test table"); my $sth2; ok($sth2 = $dbh->prepare('INSERT INTO dbd_mysql_t40serverprepare2 VALUES (?,?,?,?)')); #bind test values ok($sth2->bind_param(1, 101, DBI::SQL_INTEGER), "binding int"); ok($sth2->bind_param(2, 102, DBI::SQL_SMALLINT), "binding smallint"); ok($sth2->bind_param(3, 103, DBI::SQL_TINYINT), "binding tinyint"); ok($sth2->bind_param(4, '8589934697', DBI::SQL_BIGINT), "binding bigint"); ok($sth2->execute(), "inserting data"); is_deeply($dbh->selectall_arrayref('SELECT * FROM dbd_mysql_t40serverprepare2'), [[101, 102, 103, '8589934697']]); ok ($dbh->do(qq{DROP TABLE dbd_mysql_t40serverprepare2}), "cleaning up"); # # Bug LONGBLOB wants 4GB memory # ok($dbh->do(qq{DROP TABLE IF EXISTS t3}), "making slate clean"); ok($dbh->do(q{CREATE TABLE t3 (id INT, mydata LONGBLOB)}), "creating test table"); my $sth3; ok($sth3 = $dbh->prepare(q{INSERT INTO t3 VALUES (?,?)})); ok($sth3->execute(1, 2), "insert t3"); is_deeply($dbh->selectall_arrayref('SELECT id, mydata FROM t3'), [[1, 2]]); my $dbname = $dbh->selectrow_arrayref("SELECT DATABASE()")->[0]; $dbh->{mysql_server_prepare_disable_fallback} = 1; my $error_handler_called = 0; $dbh->{HandleError} = sub { $error_handler_called = 1; die $_[0]; }; eval { $dbh->prepare("USE $dbname") }; $dbh->{HandleError} = undef; ok($error_handler_called, 'USE is not supported with mysql_server_prepare_disable_fallback=1'); $dbh->{mysql_server_prepare_disable_fallback} = 0; my $sth4; ok($sth4 = $dbh->prepare("USE $dbname"), 'USE is supported with mysql_server_prepare_disable_fallback=0'); ok($sth4->execute()); ok($sth4->finish()); ok ($dbh->do(qq{DROP TABLE t3}), "cleaning up"); $dbh->disconnect(); ��57trackgtid.t��0000644��00000001660�15125143222�0007061 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require "lib.pl"; my $dbh; eval{$dbh = DBI->connect($test_dsn, $test_user, $test_password, {RaiseError => 1});}; if ($@) { plan skip_all => "no database connection"; } if ($dbh->{mysql_serverversion} > 100000) { plan skip_all => "GTID tracking is not available on MariaDB"; } if ($dbh->{mysql_serverversion} < 50000) { plan skip_all => "You must have MySQL version 5.0.0 and greater for this test to run"; } my @gtidtrackenabled = $dbh->selectrow_array('select @@global.session_track_gtids'); if (!@gtidtrackenabled) { plan skip_all => 'GTID tracking not available'; } elsif ($gtidtrackenabled[0] eq 'OFF') { plan skip_all => 'GTID tracking not enabled'; } else { plan tests => 2; } $dbh->do('FLUSH PRIVILEGES'); cmp_ok(length($dbh->{'mysql_gtids'}),'>=',38); ok $dbh->disconnect(); ��55utf8.t��0000644��00000005704�15125143222�0005774 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use vars qw($test_dsn $test_user $test_password); use vars qw($COL_NULLABLE $COL_KEY); use lib 't', '.'; require 'lib.pl'; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } # # DROP/CREATE PROCEDURE will give syntax error for these versions # if ($dbh->{mysql_serverversion} < 50000) { plan skip_all => "SKIP TEST: You must have MySQL version 5.0 and greater for this test to run"; } plan tests => 16 * 2; for my $mysql_server_prepare (0, 1) { $dbh= DBI->connect("$test_dsn;mysql_server_prepare=$mysql_server_prepare;mysql_server_prepare_disable_fallback=1", $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 }); ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t55utf8"); my $create =<<EOT; CREATE TABLE dbd_mysql_t55utf8 ( name VARCHAR(64) CHARACTER SET utf8, bincol BLOB, shape GEOMETRY, binutf VARCHAR(64) CHARACTER SET utf8 COLLATE utf8_bin, profile TEXT CHARACTER SET utf8 ) EOT ok $dbh->do($create); my $utf8_str = "\x{0100}dam"; # "Adam" with a macron. my $quoted_utf8_str = "'\x{0100}dam'"; my $blob = "\x{c4}\x{80}dam"; # same as utf8_str but not utf8 encoded my $quoted_blob = "'\x{c4}\x{80}dam'"; cmp_ok $dbh->quote($utf8_str), 'eq', $quoted_utf8_str, 'testing quoting of utf 8 string'; cmp_ok $dbh->quote($blob), 'eq', $quoted_blob, 'testing quoting of blob'; #ok $dbh->{mysql_enable_utf8}, "mysql_enable_utf8 survive connect()"; $dbh->{mysql_enable_utf8}=1; # GeomFromText() is deprecated as of MySQL 5.7.6, use ST_GeomFromText() instead my $geomfromtext = $dbh->{mysql_serverversion} >= 50706 ? 'ST_GeomFromText' : 'GeomFromText'; my $query = <<EOI; INSERT INTO dbd_mysql_t55utf8 (name, bincol, shape, binutf, profile) VALUES (?, ?, $geomfromtext('Point(132865 501937)'), ?, ?) EOI ok $dbh->do($query, {}, $utf8_str, $blob, $utf8_str, $utf8_str), "INSERT query $query\n"; # AsBinary() is deprecated as of MySQL 5.7.6, use ST_AsBinary() instead my $asbinary = $dbh->{mysql_serverversion} >= 50706 ? 'ST_AsBinary' : 'AsBinary'; $query = "SELECT name,bincol,$asbinary(shape), binutf, profile FROM dbd_mysql_t55utf8 LIMIT 1"; my $sth = $dbh->prepare($query) or die "$DBI::errstr"; ok $sth->execute; my $ref; $ref = $sth->fetchrow_arrayref ; ok defined $ref; cmp_ok $ref->[0], 'eq', $utf8_str; cmp_ok $ref->[3], 'eq', $utf8_str; cmp_ok $ref->[4], 'eq', $utf8_str; SKIP: { eval {use Encode;}; skip "Can't test is_utf8 tests 'use Encode;' not available", 2, if $@; ok !Encode::is_utf8($ref->[1]), "blob was made utf8!."; ok !Encode::is_utf8($ref->[2]), "shape was made utf8!."; } cmp_ok $ref->[1], 'eq', $blob, "compare $ref->[1] eq $blob"; ok $sth->finish; ok $dbh->do("DROP TABLE dbd_mysql_t55utf8"); ok $dbh->disconnect; } ��70takeimp.t��0000644��00000005221�15125143222�0006527 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use lib 't', '.'; require 'lib.pl'; $\|= 1; use vars qw($test_dsn $test_user $test_password); my $drh; eval {$drh = DBI->install_driver('mysql')}; if ($@) { plan skip_all => "Can't obtain driver handle ERROR: $@. Can't continue test"; } my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 })}; if ($@) { plan skip_all => "no database connection"; } plan tests => 21; pass("obtained driver handle"); pass("connected to database"); my $id= connection_id($dbh); ok defined($id), "Initial connection: $id\n"; $drh = $dbh->{Driver}; ok $drh, "Driver handle defined\n"; my $imp_data; $imp_data = $dbh->take_imp_data; ok $imp_data, "Didn't get imp_data"; my $imp_data_length= length($imp_data); cmp_ok $imp_data_length, '>=', 80, "test that our imp_data is greater than or equal to 80, actual $imp_data_length"; is $drh->{Kids}, 0, 'our Driver should have 0 Kid(s) after calling take_imp_data'; { my $warn; local $SIG{__WARN__} = sub { ++$warn if $_[0] =~ /after take_imp_data/ }; my $drh = $dbh->{Driver}; ok !defined($drh), '... our Driver should be undefined'; my $trace_level = $dbh->{TraceLevel}; ok !defined($trace_level) ,'our TraceLevel should be undefined'; ok !defined($dbh->disconnect), 'disconnect should return undef'; ok !defined($dbh->quote(42)), 'quote should return undefined'; is $warn, 4, 'we should have received 4 warnings'; } my $dbh2 = DBI->connect($test_dsn, $test_user, $test_password, { dbi_imp_data => $imp_data }); # XXX: how can we test that the same connection is used? my $id2 = connection_id($dbh2); note "Overridden connection: $id2\n"; cmp_ok $id,'==', $id2, "the same connection: $id => $id2\n"; my $drh2; ok $drh2 = $dbh2->{Driver}, "can't get the driver\n"; ok $dbh2->isa("DBI::db"), 'isa test'; # need a way to test dbi_imp_data has been used is $drh2->{Kids}, 1, "our Driver should have 1 Kid(s) again: having " . $drh2->{Kids} . "\n"; is $drh2->{ActiveKids}, 1, "our Driver should have 1 ActiveKid again: having " . $drh2->{ActiveKids} . "\n"; read_write_test($dbh2); # must cut the connection data again ok ($imp_data = $dbh2->take_imp_data, "didn't get imp_data"); sub read_write_test { my ($dbh)= @_; # now the actual test: ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t70takeimp"); my $create= <<EOT; CREATE TABLE dbd_mysql_t70takeimp ( id int(4) NOT NULL default 0, name varchar(64) NOT NULL default '' ); EOT ok $dbh->do($create); ok $dbh->do("DROP TABLE dbd_mysql_t70takeimp"); } ��99_bug_server_prepare_blob_null.t��0000644��00000002601�15125143222�0013157 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use vars qw($test_dsn $test_user $test_password); use vars qw($COL_NULLABLE $COL_KEY); use lib 't', '.'; require 'lib.pl'; my $dbh; $test_dsn .= ';mysql_server_prepare=1;mysql_server_prepare_disable_fallback=1'; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } # # DROP/CREATE PROCEDURE will give syntax error for these versions # if (!MinimumVersion($dbh, '5.0')) { plan skip_all => "SKIP TEST: You must have MySQL version 5.0 and greater for this test to run"; } plan tests => 11; ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t99_prepare"); my $create =<<EOT; CREATE TABLE dbd_mysql_t99_prepare ( data LONGBLOB ) EOT ok $dbh->do($create); $dbh->do("insert into dbd_mysql_t99_prepare (data) values(null)"); my $sth = $dbh->prepare("select data from dbd_mysql_t99_prepare"); ok $sth->execute; my $row = $sth->fetch; is $row->[0] => undef; ok $sth->finish; $dbh->do("insert into dbd_mysql_t99_prepare (data) values('a')"); $sth = $dbh->prepare("select data from dbd_mysql_t99_prepare"); ok $sth->execute; $row = $sth->fetch; is $row->[0] => undef; $row = $sth->fetch; is $row->[0] => 'a'; ok $sth->finish; ok $dbh->do("DROP TABLE dbd_mysql_t99_prepare"); ok $dbh->disconnect; ��29warnings.t��0000644��00000003357�15125143222�0006741 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use lib '.', 't'; require 'lib.pl'; $\|= 1; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0});}; if ($@) { plan skip_all => "no database connection"; } if ($dbh->{mysql_serverversion} < 40101) { plan skip_all => "Servers < 4.1.1 do not report warnings"; } my $expected_warnings = 2; if ($dbh->{mysql_serverversion} >= 50000 && $dbh->{mysql_serverversion} < 50500) { $expected_warnings = 1; } plan tests => 14; ok(defined $dbh, "Connected to database"); ok(my $sth= $dbh->prepare("DROP TABLE IF EXISTS no_such_table")); ok($sth->execute()); is($sth->{mysql_warning_count}, 1, 'warnings from sth'); ok($dbh->do("SET sql_mode=''")); ok($dbh->do("CREATE TEMPORARY TABLE dbd_drv_sth_warnings (c CHAR(1))")); ok($dbh->do("INSERT INTO dbd_drv_sth_warnings (c) VALUES ('perl'), ('dbd'), ('mysql')")); is($dbh->{mysql_warning_count}, 3, 'warnings from dbh'); # tests to make sure mysql_warning_count is the same as reported by mysql_info(); # see https://rt.cpan.org/Ticket/Display.html?id=29363 ok($dbh->do("CREATE TEMPORARY TABLE dbd_drv_count_warnings (i TINYINT NOT NULL)") ); my $q = "INSERT INTO dbd_drv_count_warnings VALUES (333),('as'),(3)"; ok($sth = $dbh->prepare($q)); ok($sth->execute()); is($sth->{'mysql_warning_count'}, 2 ); # $dbh->{info} actually uses mysql_info() my $str = $dbh->{info}; my $numwarn; if ( $str =~ /Warnings:\s(\d+)$/ ) { $numwarn = $1; } # this test passes on mysql 5.5.x and fails on 5.1.x # but I'm not sure which versions, so I'll just disable it for now is($numwarn, $expected_warnings); ok($dbh->disconnect); ��41bindparam.t��0000644��00000002026�15125143222�0007030 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my ($dbh, $sth); eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 11; my ($rows, $errstr, $ret_ref); ok $dbh->do("drop table if exists dbd_mysql_41bindparam"), "drop table dbd_mysql_41bindparam"; ok $dbh->do("create table dbd_mysql_41bindparam (a int not null, primary key (a))"), "create table dbd_mysql_41bindparam"; ok ($sth= $dbh->prepare("insert into dbd_mysql_41bindparam values (?)")); ok $sth->bind_param(1,10000,DBI::SQL_INTEGER), "bind param 10000 col1"; ok $sth->execute(), 'execute'; ok $sth->bind_param(1,10001,DBI::SQL_INTEGER), "bind param 10001 col1"; ok $sth->execute(), 'execute'; ok ($sth= $dbh->prepare("DROP TABLE dbd_mysql_41bindparam")); ok $sth->execute(); ok $sth->finish; ok $dbh->disconnect; ��rt110983-valid-mysqlfd.t��0000644��00000001324�15125143222�0010613 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use vars qw($test_dsn $test_user $test_password); require "t/lib.pl"; my $dbh = eval { DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 0 }) }; plan skip_all => "no database connection" if $@ or not $dbh; plan tests => 4; ok($dbh->mysql_fd >= 0, '$dbh->mysql_fd returns valid file descriptor when $dbh connection is open'); ok($dbh->{sockfd} >= 0, '$dbh->{sockfd} returns valid file descriptor when $dbh connection is open'); $dbh->disconnect; ok(!defined $dbh->mysql_fd, '$dbh->mysql_fd returns undef when $dbh connection was closed'); ok(!defined $dbh->{sockfd}, '$dbh->{sockfd} returns undef when $dbh connection was closed'); ��42bindparam.t��0000644��00000001745�15125143222�0007040 0��ustar�00��use strict; use warnings; use vars qw($test_dsn $test_user $test_password $mdriver); use Test::More; use DBI; use lib 't', '.'; require 'lib.pl'; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 12; ok $dbh->do("drop table if exists dbd_mysql_t42bindparams"); my $create= <<EOT; create table dbd_mysql_t42bindparams ( a int not null, b double, primary key (a)) EOT ok $dbh->do($create); ok (my $sth= $dbh->prepare("insert into dbd_mysql_t42bindparams values (?, ?)")); ok $sth->bind_param(1,"10000 ",DBI::SQL_INTEGER); ok $sth->bind_param(2,"1.22 ",DBI::SQL_DOUBLE); ok $sth->execute(); ok $sth->bind_param(1,10001,DBI::SQL_INTEGER); ok $sth->bind_param(2,.3333333,DBI::SQL_DOUBLE); ok $sth->execute(); ok $dbh->do("DROP TABLE dbd_mysql_t42bindparams"); ok $sth->finish; ok $dbh->disconnect; ��rt91715.t��0000644��00000001522�15125143222�0005762 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use vars qw($mdriver); $\|= 1; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my $dbh; # yes, we will reconnect, but I want to keep the "fail if not connect" # separate from the actual test where we reconnect eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 1 });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 6; for my $ur (0,1) { $test_dsn .= ";mysql_use_result=1" if $ur; # reconnect ok ($dbh->disconnect()); ok ($dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 })); is $dbh->{mysql_use_result}, $ur, "mysql_use_result set to $ur"; } ��41blobs_prepare.t��0000644��00000004055�15125143222�0007716 0��ustar�00��use strict; use warnings; use DBI; use Test::More; my $update_blob; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my $dbh; eval {$dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1})}; if ($@) { plan skip_all => "no database connection"; } plan tests => 25; my @chars = grep !/[0O1Iil]/, 0..9, 'A'..'Z', 'a'..'z'; my $blob1= join '', map { $chars[rand @chars] } 0 .. 10000; my $blob2 = '"' x 10000; sub ShowBlob($) { my ($blob) = @_; my $b; for(my $i = 0; $i < 8; $i++) { if (defined($blob) && length($blob) > $i) { $b = substr($blob, $i32); } else { $b = ""; } note sprintf("%08lx %s\n", $i32, unpack("H64", $b)); } } my $create = <<EOT; CREATE TABLE dbd_mysql_41blobs_prepare ( id int(4), name text) EOT ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_41blobs_prepare"), "drop table if exists dbd_mysql_41blobs_prepare"; ok $dbh->do($create), "create table dbd_mysql_41blobs_prepare"; my $query = "INSERT INTO dbd_mysql_41blobs_prepare VALUES(?, ?)"; my $sth; ok ($sth= $dbh->prepare($query)); ok defined($sth); ok $sth->execute(1, $blob1), "inserting \$blob1"; ok $sth->finish; ok ($sth= $dbh->prepare("SELECT * FROM dbd_mysql_41blobs_prepare WHERE id = 1")); ok $sth->execute, "select from dbd_mysql_41blobs_prepare"; ok (my $row = $sth->fetchrow_arrayref); is @$row, 2, "two rows fetched"; is $$row[0], 1, "first row id == 1"; cmp_ok $$row[1], 'eq', $blob1, ShowBlob($blob1); ok $sth->finish; ok ($sth= $dbh->prepare("UPDATE dbd_mysql_41blobs_prepare SET name = ? WHERE id = 1")); ok $sth->execute($blob2), 'inserting $blob2'; ok ($sth->finish); ok ($sth= $dbh->prepare("SELECT * FROM dbd_mysql_41blobs_prepare WHERE id = 1")); ok ($sth->execute); ok ($row = $sth->fetchrow_arrayref); is scalar @$row, 2, 'two rows'; is $$row[0], 1, 'row id == 1'; cmp_ok $$row[1], 'eq', $blob2, ShowBlob($blob2); ok ($sth->finish); ok $dbh->do("DROP TABLE dbd_mysql_41blobs_prepare"), "drop dbd_mysql_41blobs_prepare"; ok $dbh->disconnect; ��00base.t��0000644��00000001172�15125143222�0006001 0��ustar�00��use strict; use warnings; use Test::More tests => 6; # # Include lib.pl # use lib 't', '.'; require 'lib.pl'; # Base DBD Driver Test BEGIN { use_ok('DBI') or BAIL_OUT "Unable to load DBI"; use_ok('DBD::mysql') or BAIL_OUT "Unable to load DBD::mysql"; } my $switch = DBI->internal; cmp_ok ref $switch, 'eq', 'DBI::dr', 'Internal set'; # This is a special case. install_driver should not normally be used. my $drh= DBI->install_driver('mysql'); ok $drh, 'Install driver'; cmp_ok ref $drh, 'eq', 'DBI::dr', 'DBI::dr set'; ok $drh->{Version}, "Version $drh->{Version}"; diag "Driver version is ", $drh->{Version}, "\n"; ��87async.t��0000644��00000014130�15125143222�0006221 0��ustar�00��use strict; use warnings; use Test::Deep; use Test::More; use DBI; use DBI::Const::GetInfoType; use Time::HiRes; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 0, PrintError => 0, AutoCommit => 0 });}; if (!$dbh) { plan skip_all => "no database connection"; } if ($dbh->{mysql_serverversion} < 50012) { plan skip_all => "Servers < 5.0.12 do not support SLEEP()"; } plan tests => 92; is $dbh->get_info($GetInfoType{'SQL_ASYNC_MODE'}), 2; # statement-level async is $dbh->get_info($GetInfoType{'SQL_MAX_ASYNC_CONCURRENT_STATEMENTS'}), 1; $dbh->do(<<SQL); CREATE TEMPORARY TABLE async_test ( value0 INTEGER, value1 INTEGER, value2 INTEGER ); SQL ok $dbh->mysql_fd; ok !defined($dbh->mysql_async_ready); my ( $start, $end ); my $rows; my $sth; my ( $a, $b, $c ); $start = Time::HiRes::gettimeofday(); $rows = $dbh->do('INSERT INTO async_test VALUES (SLEEP(2), 0, 0)'); $end = Time::HiRes::gettimeofday(); is $rows, 1; ok(($end - $start) >= 2); $start = Time::HiRes::gettimeofday(); $rows = $dbh->do('INSERT INTO async_test VALUES (SLEEP(2), 0, 0)', { async => 1 }); ok(defined($dbh->mysql_async_ready)) or die; $end = Time::HiRes::gettimeofday(); ok $rows; is $rows, '0E0'; ok(($end - $start) < 2); sleep 1 until $dbh->mysql_async_ready; $end = Time::HiRes::gettimeofday(); ok(($end - $start) >= 2); $rows = $dbh->mysql_async_result; ok !defined($dbh->mysql_async_ready); is $rows, 1; ( $rows ) = $dbh->selectrow_array('SELECT COUNT(1) FROM async_test'); is $rows, 2; $dbh->do('DELETE FROM async_test'); $start = Time::HiRes::gettimeofday(); $rows = $dbh->do('INSERT INTO async_test VALUES(SLEEP(2), ?, ?)', { async => 1 }, 1, 2); $end = Time::HiRes::gettimeofday(); ok $rows; is $rows, '0E0'; ok(($end - $start) < 2); sleep 1 until $dbh->mysql_async_ready; $end = Time::HiRes::gettimeofday(); ok(($end - $start) >= 2); $rows = $dbh->mysql_async_result; is $rows, 1; ( $a, $b, $c ) = $dbh->selectrow_array('SELECT * FROM async_test'); is $a, 0; is $b, 1; is $c, 2; $sth = $dbh->prepare('SELECT SLEEP(2)'); ok !defined($sth->mysql_async_ready); $start = Time::HiRes::gettimeofday(); ok $sth->execute; $end = Time::HiRes::gettimeofday(); ok(($end - $start) >= 2); $sth = $dbh->prepare('SELECT SLEEP(2)', { async => 1 }); ok !defined($sth->mysql_async_ready); $start = Time::HiRes::gettimeofday(); ok $sth->execute; ok defined($sth->mysql_async_ready); $end = Time::HiRes::gettimeofday(); ok(($end - $start) < 2); sleep 1 until $sth->mysql_async_ready; my $row = $sth->fetch; $end = Time::HiRes::gettimeofday(); ok $row; is $row->[0], 0; ok(($end - $start) >= 2); $rows = $dbh->do('INSERT INTO async_test VALUES(SLEEP(2), ?, ?', { async => 1 }, 1, 2); ok $rows; ok !$dbh->errstr; $rows = $dbh->mysql_async_result; ok !$rows; ok $dbh->errstr; $dbh->do('DELETE FROM async_test'); $sth = $dbh->prepare('INSERT INTO async_test VALUES(SLEEP(2), ?, ?)', { async => 1 }); $start = Time::HiRes::gettimeofday(); $rows = $sth->execute(1, 2); $end = Time::HiRes::gettimeofday(); ok(($end - $start) < 2); ok $rows; is $rows, '0E0'; $rows = $sth->mysql_async_result; $end = Time::HiRes::gettimeofday(); ok(($end - $start) >= 2); is $rows, 1; ( $a, $b, $c ) = $dbh->selectrow_array('SELECT * FROM async_test'); is $a, 0; is $b, 1; is $c, 2; $sth = $dbh->prepare('INSERT INTO async_test VALUES(SLEEP(2), ?, ?)', { async => 1 }); $rows = $dbh->do('INSERT INTO async_test VALUES(SLEEP(2), ?, ?)', undef, 1, 2); is $rows, 1; $start = Time::HiRes::gettimeofday(); $dbh->selectrow_array('SELECT SLEEP(2)', { async => 1 }); $end = Time::HiRes::gettimeofday(); ok(($end - $start) >= 2); ok !defined($dbh->mysql_async_result); ok !defined($dbh->mysql_async_ready); $rows = $dbh->do('UPDATE async_test SET value0 = 0 WHERE value0 = 999', { async => 1 }); ok $rows; is $rows, '0E0'; $rows = $dbh->mysql_async_result; ok $rows; is $rows, '0E0'; $sth = $dbh->prepare('UPDATE async_test SET value0 = 0 WHERE value0 = 999', { async => 1 }); $rows = $sth->execute; ok $rows; is $rows, '0E0'; $rows = $sth->mysql_async_result; ok $rows; is $rows, '0E0'; $sth->execute; $rows = $dbh->do('INSERT INTO async_test VALUES(1, 2, 3)'); ok !$rows; undef $sth; $rows = $dbh->do('INSERT INTO async_test VALUES(1, 2, 3)'); is $rows, 1; $sth = $dbh->prepare('SELECT 1, value0, value1, value2 FROM async_test WHERE value0 = ?', { async => 1 }); $sth->execute(1); is $sth->{'NUM_OF_FIELDS'}, undef; is $sth->{'NUM_OF_PARAMS'}, 1; is $sth->{'NAME'}, undef; is $sth->{'NAME_lc'}, undef; is $sth->{'NAME_uc'}, undef; is $sth->{'NAME_hash'}, undef; is $sth->{'NAME_lc_hash'}, undef; is $sth->{'NAME_uc_hash'}, undef; is $sth->{'TYPE'}, undef; is $sth->{'PRECISION'}, undef; is $sth->{'SCALE'}, undef; is $sth->{'NULLABLE'}, undef; is $sth->{'Database'}, $dbh; is $sth->{'Statement'}, 'SELECT 1, value0, value1, value2 FROM async_test WHERE value0 = ?'; $sth->mysql_async_result; is $sth->{'NUM_OF_FIELDS'}, 4; is $sth->{'NUM_OF_PARAMS'}, 1; cmp_bag $sth->{'NAME'}, [qw/1 value0 value1 value2/]; cmp_bag $sth->{'NAME_lc'}, [qw/1 value0 value1 value2/]; cmp_bag $sth->{'NAME_uc'}, [qw/1 VALUE0 VALUE1 VALUE2/]; cmp_bag [ keys %{$sth->{'NAME_hash'}} ], [qw/1 value0 value1 value2/]; cmp_bag [ keys %{$sth->{'NAME_lc_hash'}} ], [qw/1 value0 value1 value2/]; cmp_bag [ keys %{$sth->{'NAME_uc_hash'}} ], [qw/1 VALUE0 VALUE1 VALUE2/]; is ref($sth->{'TYPE'}), 'ARRAY'; is ref($sth->{'PRECISION'}), 'ARRAY'; is ref($sth->{'SCALE'}), 'ARRAY'; is ref($sth->{'NULLABLE'}), 'ARRAY'; is $sth->{'Database'}, $dbh; is $sth->{'Statement'}, 'SELECT 1, value0, value1, value2 FROM async_test WHERE value0 = ?'; $sth->finish; $sth->execute(1); $row = $sth->fetch; is_deeply $row, [1, 1, 2, 3]; $sth->finish; $sth->execute(1); $row = $sth->fetchrow_arrayref; is_deeply $row, [1, 1, 2, 3]; $sth->finish; $sth->execute(1); my @row = $sth->fetchrow_array; is_deeply \@row, [1, 1, 2, 3]; $sth->finish; $sth->execute(1); $row = $sth->fetchrow_hashref; cmp_bag [ keys %$row ], [qw/1 value0 value1 value2/]; cmp_bag [ values %$row ], [1, 1, 2, 3]; $sth->finish; undef $sth; ok $dbh->disconnect; ��92ssl_riddle_vulnerability.t��0000644��00000002756�15125143222�0012210 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require "lib.pl"; my $dbh = DbiTestConnect($test_dsn, $test_user, $test_password, { PrintError => 0, RaiseError => 1 }); my $have_ssl = eval { $dbh->selectrow_hashref("SHOW VARIABLES WHERE Variable_name = 'have_ssl'") }; $dbh->disconnect(); plan skip_all => 'Server supports SSL connections, cannot test false-positive enforcement' if $have_ssl and $have_ssl->{Value} eq 'YES'; # `have_ssl` has been deprecated in 8.0.26 and removed in 8.4.0... plan skip_all => 'Server might support SSL connections, cannot test false-positive enforcement' if not $have_ssl; plan tests => 4; $dbh = DBI->connect($test_dsn, '4yZ73s9qeECdWi', '64heUGwAsVoNqo', { PrintError => 0, RaiseError => 0, mysql_ssl => 1 }); ok(!defined $dbh, 'DBD::mysql refused connection to non-SSL server with mysql_ssl=1 and incorrect user and password'); is($DBI::err, 2026, 'DBD::mysql error message is SSL related') or diag('Error message: ' . ($DBI::errstr \|\| 'unknown')); $dbh = DBI->connect($test_dsn, '4yZ73s9qeECdWi', '64heUGwAsVoNqo', { PrintError => 0, RaiseError => 0, mysql_ssl => 1, mysql_ssl_verify_server_cert => 1, mysql_ssl_ca_file => "" }); ok(!defined $dbh, 'DBD::mysql refused connection to non-SSL server with mysql_ssl=1, mysql_ssl_verify_server_cert=1 and incorrect user and password'); is($DBI::err, 2026, 'DBD::mysql error message is SSL related') or diag('Error message: ' . ($DBI::errstr \|\| 'unknown')); ��65types.t��0000644��00000002474�15125143222�0006254 0��ustar�00��use strict; use warnings; use vars qw($test_dsn $test_user $test_password); use Test::More; use DBI; use lib 't', '.'; require 'lib.pl'; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 19; ok $dbh->do("drop table if exists dbd_mysql_65types"); my $create= <<EOT; create table dbd_mysql_65types ( a int, primary key (a) ) EOT ok $dbh->do($create); my $sth; eval {$sth= $dbh->prepare("insert into dbd_mysql_65types values (?)")}; ok ! $@, "prepare: $@"; ok $sth->bind_param(1,10000,DBI::SQL_INTEGER); ok $sth->execute(); ok $sth->bind_param(1,10001,DBI::SQL_INTEGER); ok $sth->execute(); ok $dbh->do("DROP TABLE dbd_mysql_65types"); ok $dbh->do("create table dbd_mysql_65types (a int, b double, primary key (a))"); eval { $sth= $dbh->prepare("insert into dbd_mysql_65types values (?, ?)")}; ok ! $@, "prepare: $@"; ok $sth->bind_param(1,"10000 ",DBI::SQL_INTEGER); ok $sth->bind_param(2,"1.22 ",DBI::SQL_DOUBLE); ok $sth->execute(); ok $sth->bind_param(1,10001,DBI::SQL_INTEGER); ok $sth->bind_param(2,.3333333,DBI::SQL_DOUBLE); ok $sth->execute(); ok $sth->finish; ok $dbh->do("DROP TABLE dbd_mysql_65types"); ok $dbh->disconnect; ��40nulls.t��0000644��00000001754�15125143222�0006236 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my ($dbh, $sth); eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 10; ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t40nulls"), "DROP TABLE IF EXISTS dbd_mysql_t40nulls"; my $create= <<EOT; CREATE TABLE dbd_mysql_t40nulls ( id INT(4), name VARCHAR(64) ) EOT ok $dbh->do($create), "create table $create"; ok $dbh->do("INSERT INTO dbd_mysql_t40nulls VALUES ( NULL, 'NULL-valued id' )"), "inserting nulls"; ok ($sth = $dbh->prepare("SELECT * FROM dbd_mysql_t40nulls WHERE id IS NULL")); do $sth->execute; ok (my $aref = $sth->fetchrow_arrayref); ok !defined($$aref[0]); ok defined($$aref[1]); ok $sth->finish; ok $dbh->do("DROP TABLE dbd_mysql_t40nulls"); ok $dbh->disconnect; ��40keyinfo.t��0000644��00000003362�15125143222�0006542 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use lib 't', '.'; require 'lib.pl'; $\|= 1; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } $dbh->{mysql_server_prepare}= 0; ok(defined $dbh, "Connected to database for key info tests"); ok($dbh->do("DROP TABLE IF EXISTS dbd_mysql_keyinfo"), "Dropped table"); # Non-primary key is there as a regression test for Bug #26786. ok($dbh->do("CREATE TABLE dbd_mysql_keyinfo (a int, b varchar(20), c int, primary key (a,b(10)), key (c))"), "Created table dbd_mysql_keyinfo"); my $sth= $dbh->primary_key_info(undef, undef, 'dbd_mysql_keyinfo'); ok($sth, "Got primary key info"); my $key_info= $sth->fetchall_arrayref; my $expect= [ [ undef, undef, 'dbd_mysql_keyinfo', 'a', '1', 'PRIMARY' ], [ undef, undef, 'dbd_mysql_keyinfo', 'b', '2', 'PRIMARY' ], ]; is_deeply($key_info, $expect, "Check primary_key_info results"); is_deeply([ $dbh->primary_key(undef, undef, 'dbd_mysql_keyinfo') ], [ 'a', 'b' ], "Check primary_key results"); $sth= $dbh->statistics_info(undef, undef, 'dbd_mysql_keyinfo', 0, 0); my $stats_info = $sth->fetchall_arrayref; my $n_unique = grep $_->[3], @$stats_info; $sth= $dbh->statistics_info(undef, undef, 'dbd_mysql_keyinfo', 1, 0); $stats_info = $sth->fetchall_arrayref; my $n_unique2 = grep $_->[3], @$stats_info; isnt($n_unique2, $n_unique, "Check statistics_info unique_only flag has an effect"); ok($dbh->do("DROP TABLE dbd_mysql_keyinfo"), "Dropped table"); $dbh->disconnect(); done_testing; ��manifest.t��0000644��00000000421�15125143222�0006531 0��ustar�00��#!perl -T use strict; use warnings; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Release tests not required for installation" ); } eval "use Test::CheckManifest 0.9"; plan skip_all => "Test::CheckManifest 0.9 required" if $@; ok_manifest(); ��75supported_sql.t��0000644��00000002334�15125143222�0010010 0��ustar�00��use strict; use warnings; use vars qw($test_dsn $test_user $test_password); use DBI; use Test::More; use lib 't', '.'; require 'lib.pl'; my ($row, $vers, $test_procs); my $dbh; eval {$dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1})}; if ($@) { plan skip_all => "no database connection"; } plan tests => 12; ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t75supported"); my $create = <<EOT; CREATE TABLE dbd_mysql_t75supported ( id INT(4), name VARCHAR(32) ) EOT ok $dbh->do($create),"create dbd_mysql_t75supported"; my $sth; ok ($sth= $dbh->prepare("SHOW TABLES LIKE 'dbd_mysql_t75supported'")); ok $sth->execute(); ok ($row= $sth->fetchrow_arrayref); cmp_ok $row->[0], 'eq', 'dbd_mysql_t75supported', "\$row->[0] eq dbd_mysql_t75supported"; ok $sth->finish; ok $dbh->do("DROP TABLE dbd_mysql_t75supported"), "drop dbd_mysql_t75supported"; ok $dbh->do("CREATE TABLE dbd_mysql_t75supported (a int)"), "creating dbd_mysql_t75supported again with 1 col"; ok $dbh->do("ALTER TABLE dbd_mysql_t75supported ADD COLUMN b varchar(31)"), "alter dbd_mysql_t75supported ADD COLUMN"; ok $dbh->do("DROP TABLE dbd_mysql_t75supported"), "drop dbd_mysql_t75supported"; ok $dbh->disconnect; ��rt25389-bin-case.t��0000644��00000002704�15125143222�0007450 0��ustar�00��use strict; use warnings; use DBI; use vars qw($test_dsn $test_user $test_password); require "t/lib.pl"; use Test::More; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 0, AutoCommit => 1 });}; if ($@) { plan skip_all => "no database connection"; } if (!MinimumVersion($dbh, '5.1')) { plan skip_all => "You must have MySQL version 5.1 or greater for this test" } plan tests => 8; my ( $sth, $i ); my @test = qw(AA Aa aa aA); for my $charset (qw(latin1 utf8)) { for my $unique ( "", "unique" ) { my $table = "dbd-mysql-$charset-$unique"; my $create = "CREATE TEMPORARY TABLE `$table` (name VARCHAR(8) CHARACTER SET $charset COLLATE ${charset}_bin $unique)"; $dbh->do($create) or die $DBI::errstr; for (@test) { $dbh->do("insert into `$table` values ('$_')"); } my $q1 = "select name from `$table`"; $sth = $dbh->prepare($q1); $sth->execute; $i = 0; while ( my @row = $sth->fetchrow ) { $i++; } is( $i, scalar @test, $q1 ); $sth->finish; my $q2 = "select name from `$table` where " . join( " OR ", map { "name = '$_'" } @test ); $sth = $dbh->prepare($q2); $sth->execute; $i = 0; while ( my @row = $sth->fetchrow ) { $i++; } is( $i, scalar @test, $q2 ); } } ��version.t��0000644��00000000626�15125143222�0006417 0��ustar�00��use strict; use warnings; use DBD::mysql; use Test::More; like($DBD::mysql::VERSION, qr/^\d\.\d{2,3}(\|_\d\d)$/, 'version format'); like($DBD::mysql::VERSION, qr/^5\./, 'version starts with "5." (update for 6.x)'); diag("mysql_get_client_version: ", DBD::mysql->client_version); cmp_ok(DBD::mysql->client_version, ">", 0, "mysql_get_client_version is available as a standalone function"); done_testing; ��40bindparam2.t��0000644��00000002501�15125143222�0007107 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my $dbh; eval {$dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1}) or ServerError();}; if ($@) { plan skip_all => "no database connection"; } plan tests => 13; SKIP: { skip 'SET @@auto_increment_offset needs MySQL >= 5.0.2', 2 unless $dbh->{mysql_serverversion} >= 50002; ok $dbh->do('SET @@auto_increment_offset = 1'); ok $dbh->do('SET @@auto_increment_increment = 1'); } my $create= <<EOT; CREATE TEMPORARY TABLE dbd_mysql_t40bindparam2 ( id INT NOT NULL AUTO_INCREMENT PRIMARY KEY, num INT(3)) EOT ok $dbh->do($create), "create table dbd_mysql_t40bindparam2"; ok $dbh->do("INSERT INTO dbd_mysql_t40bindparam2 VALUES(NULL, 1)"), "insert into dbd_mysql_t40bindparam2 (null, 1)"; my $rows; ok ($rows= $dbh->selectall_arrayref("SELECT * FROM dbd_mysql_t40bindparam2")); is $rows->[0][1], 1, "\$rows->[0][1] == 1"; ok (my $sth = $dbh->prepare("UPDATE dbd_mysql_t40bindparam2 SET num = ? WHERE id = ?")); ok ($sth->bind_param(2, 1, SQL_INTEGER())); ok ($sth->execute()); ok ($sth->finish()); ok ($rows = $dbh->selectall_arrayref("SELECT * FROM dbd_mysql_t40bindparam2")); ok !defined($rows->[0][1]); ok ($dbh->disconnect()); ��60leaks.t��0000644��00000017301�15125143222�0006175 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my $COUNT_CONNECT = 4000; # Number of connect/disconnect iterations my $COUNT_PREPARE = 30000; # Number of prepare/execute/finish iterations my $COUNT_BIND = 10000; # Number of bind_param iterations my $have_storable; if (!$ENV{EXTENDED_TESTING}) { plan skip_all => "Skip \$ENV{EXTENDED_TESTING} is not set\n"; } eval { require Proc::ProcessTable; }; if ($@) { plan skip_all => "module Proc::ProcessTable not installed \n"; } eval { require Storable }; $have_storable = $@ ? 0 : 1; my $have_pt_size = grep { $_ eq 'size' } Proc::ProcessTable->new('cache_ttys' => $have_storable)->fields; unless ($have_pt_size) { plan skip_all => "module Proc::ProcessTable does not support size attribute on current platform\n"; } my ($dbh, $sth); eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } $dbh->disconnect; plan tests => 27 * 2; sub size { my($p, $pt); $pt = Proc::ProcessTable->new('cache_ttys' => $have_storable); for $p (@{$pt->table()}) { if ($p->pid() == $$) { return $p->size(); } } die "Cannot find my own process?!?\n"; exit 0; } for my $mysql_server_prepare (0, 1) { note "Testing memory leaks with mysql_server_prepare=$mysql_server_prepare\n"; $dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0, mysql_server_prepare => $mysql_server_prepare, mysql_server_prepare_disable_fallback => 1 }); ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t60leaks"); my $create= <<EOT; CREATE TABLE dbd_mysql_t60leaks ( id INT(4) NOT NULL DEFAULT 0, name VARCHAR(64) NOT NULL DEFAULT '' ) EOT ok $dbh->do($create); my ($size, $prev_size, $ok, $not_ok, $dbh2, $msg); note "Testing memory leaks in connect/disconnect\n"; $msg = "Possible memory leak in connect/disconnect detected"; $ok = 0; $not_ok = 0; $prev_size= undef; for (my $i = 0; $i < $COUNT_CONNECT; $i++) { eval {$dbh2 = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0, mysql_server_prepare => $mysql_server_prepare, });}; if ($@) { $not_ok++; last; } if ($i % 100 == 99) { $size = size(); if (defined($prev_size)) { if ($size == $prev_size) { $ok++; } else { $not_ok++; } } else { $prev_size = $size; $size = size(); } $prev_size = $size; } } $dbh2->disconnect; ok $ok, "\$ok $ok"; ok !$not_ok, "\$not_ok $not_ok"; cmp_ok $ok, '>', $not_ok, "\$ok $ok \$not_ok $not_ok"; note "Testing memory leaks in prepare/execute/finish\n"; $msg = "Possible memory leak in prepare/execute/finish detected"; $ok = 0; $not_ok = 0; undef $prev_size; for (my $i = 0; $i < $COUNT_PREPARE; $i++) { my $sth = $dbh->prepare("SELECT * FROM dbd_mysql_t60leaks"); $sth->execute(); $sth->finish(); if ($i % 100 == 99) { $size = size(); if (defined($prev_size)) { if ($size == $prev_size) { $ok++; } else { $not_ok++; } } else { $prev_size = $size; $size = size(); } $prev_size = $size; } } ok $ok; ok !$not_ok, "\$ok $ok \$not_ok $not_ok"; cmp_ok $ok, '>', $not_ok, "\$ok $ok \$not_ok $not_ok"; note "Testing memory leaks in execute/finish\n"; $msg = "Possible memory leak in execute/finish detected"; $ok = 0; $not_ok = 0; undef $prev_size; { my $sth = $dbh->prepare("SELECT * FROM dbd_mysql_t60leaks"); for (my $i = 0; $i < $COUNT_PREPARE; $i++) { $sth->execute(); $sth->finish(); if ($i % 100 == 99) { $size = size(); if (defined($prev_size)) { if ($size == $prev_size) { $ok++; } else { $not_ok++; } } else { $prev_size = $size; $size = size(); } $prev_size = $size; } } } ok $ok; ok !$not_ok, "\$ok $ok \$not_ok $not_ok"; cmp_ok $ok, '>', $not_ok, "\$ok $ok \$not_ok $not_ok"; note "Testing memory leaks in bind_param\n"; $msg = "Possible memory leak in bind_param detected"; $ok = 0; $not_ok = 0; undef $prev_size; { my $sth = $dbh->prepare("SELECT * FROM dbd_mysql_t60leaks WHERE id = ? AND name = ?"); for (my $i = 0; $i < $COUNT_BIND; $i++) { $sth->bind_param(1, 0); my $val = "x" x 1000000; $sth->bind_param(2, $val); if ($i % 100 == 99) { $size = size(); if (defined($prev_size)) { if ($size == $prev_size) { $ok++; } else { $not_ok++; } } else { $prev_size = $size; $size = size(); } $prev_size = $size; } } } ok $ok; ok !$not_ok, "\$ok $ok \$not_ok $not_ok"; cmp_ok $ok, '>', $not_ok, "\$ok $ok \$not_ok $not_ok"; note "Testing memory leaks in fetchrow_arrayref\n"; $msg= "Possible memory leak in fetchrow_arrayref detected"; $sth= $dbh->prepare("INSERT INTO dbd_mysql_t60leaks VALUES (?, ?)") ; my $dataref= [[1, 'Jochen Wiedmann'], [2, 'Andreas K�nig'], [3, 'Tim Bunce'], [4, 'Alligator Descartes'], [5, 'Jonathan Leffler']]; for (@$dataref) { ok $sth->execute($_->[0], $_->[1]), "insert into dbd_mysql_t60leaks values ($_->[0], '$_->[1]')"; } $ok = 0; $not_ok = 0; undef $prev_size; for (my $i = 0; $i < $COUNT_PREPARE; $i++) { { my $sth = $dbh->prepare("SELECT * FROM dbd_mysql_t60leaks"); $sth->execute(); my $row; while ($row = $sth->fetchrow_arrayref()) { } $sth->finish(); } if ($i % 100 == 99) { $size = size(); if (defined($prev_size)) { if ($size == $prev_size) { ++$ok; } else { ++$not_ok; } } else { $prev_size = $size; $size = size(); } $prev_size = $size; } } ok $ok; ok !$not_ok, "\$ok $ok \$not_ok $not_ok"; cmp_ok $ok, '>', $not_ok, "\$ok $ok \$not_ok $not_ok"; note "Testing memory leaks in fetchrow_hashref\n"; $msg = "Possible memory leak in fetchrow_hashref detected"; $ok = 0; $not_ok = 0; undef $prev_size; for (my $i = 0; $i < $COUNT_PREPARE; $i++) { { my $sth = $dbh->prepare("SELECT * FROM dbd_mysql_t60leaks"); $sth->execute(); my $row; while ($row = $sth->fetchrow_hashref()) { } $sth->finish(); } if ($i % 100 == 99) { $size = size(); if (defined($prev_size)) { if ($size == $prev_size) { ++$ok; } else { ++$not_ok; } } else { $prev_size = $size; $size = size(); } $prev_size = $size; } } ok $ok; ok !$not_ok, "\$ok $ok \$not_ok $not_ok"; cmp_ok $ok, '>', $not_ok, "\$ok $ok \$not_ok $not_ok"; ok $dbh->do("DROP TABLE dbd_mysql_t60leaks"); ok $dbh->disconnect; } ��40bindparam.t��0000644��00000005577�15125143222�0007045 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use lib 't', '.'; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 1 });}; if ($@) { plan skip_all => "no database connection"; } if (!MinimumVersion($dbh, '4.1')) { plan skip_all => "SKIP TEST: You must have MySQL version 4.1 and greater for this test to run"; } plan tests => 41; ok ($dbh->do("DROP TABLE IF EXISTS dbd_mysql_t40bindparam")); my $create = <<EOT; CREATE TABLE dbd_mysql_t40bindparam ( id int(4) NOT NULL default 0, name varchar(64) default '' ) EOT ok ($dbh->do($create)); ok (my $sth = $dbh->prepare("INSERT INTO dbd_mysql_t40bindparam VALUES (?, ?)")); # Automatic type detection my $numericVal = 1; my $charVal = "Alligator Descartes"; ok ($sth->execute($numericVal, $charVal)); # Does the driver remember the automatically detected type? ok ($sth->execute("3", "Jochen Wiedmann")); $numericVal = 2; $charVal = "Tim Bunce"; ok ($sth->execute($numericVal, $charVal)); # Now try the explicit type settings ok ($sth->bind_param(1, " 4", SQL_INTEGER())); # umlaut equivalent is vowel followed by 'e' ok ($sth->bind_param(2, 'Andreas Koenig')); ok ($sth->execute); # Works undef -> NULL? ok ($sth->bind_param(1, 5, SQL_INTEGER())); ok ($sth->bind_param(2, undef)); ok ($sth->execute); ok ($sth->bind_param(1, undef, SQL_INTEGER())); ok ($sth->bind_param(2, undef)); ok ($sth->execute(-1, "abc")); ok ($dbh->do("INSERT INTO dbd_mysql_t40bindparam VALUES (6, '?')")); ok ($dbh->do('SET @old_sql_mode = @@sql_mode, @@sql_mode = \'\'')); ok ($dbh->do("INSERT INTO dbd_mysql_t40bindparam VALUES (7, \"?\")")); ok ($dbh->do('SET @@sql_mode = @old_sql_mode')); ok ($sth = $dbh->prepare("SELECT * FROM dbd_mysql_t40bindparam ORDER BY id")); ok($sth->execute); my ($id, $name); ok ($sth->bind_columns(undef, \$id, \$name)); my $ref = $sth->fetch ; is $id, -1, 'id set to -1'; cmp_ok $name, 'eq', 'abc', 'name eq abc'; $ref = $sth->fetch; is $id, 1, 'id set to 1'; cmp_ok $name, 'eq', 'Alligator Descartes', '$name set to Alligator Descartes'; $ref = $sth->fetch; is $id, 2, 'id set to 2'; cmp_ok $name, 'eq', 'Tim Bunce', '$name set to Tim Bunce'; $ref = $sth->fetch; is $id, 3, 'id set to 3'; cmp_ok $name, 'eq', 'Jochen Wiedmann', '$name set to Jochen Wiedmann'; $ref = $sth->fetch; is $id, 4, 'id set to 4'; cmp_ok $name, 'eq', 'Andreas Koenig', '$name set to Andreas Koenig'; $ref = $sth->fetch; is $id, 5, 'id set to 5'; ok !defined($name), 'name not defined'; $ref = $sth->fetch; is $id, 6, 'id set to 6'; cmp_ok $name, 'eq', '?', "\$name set to '?'"; $ref = $sth->fetch; is $id, 7, '$id set to 7'; cmp_ok $name, 'eq', '?', "\$name set to '?'"; ok ($dbh->do("DROP TABLE dbd_mysql_t40bindparam")); ok $sth->finish; ok $dbh->disconnect; ��85init_command.t��0000644��00000001360�15125143222�0007544 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use DBI::Const::GetInfoType; $\|= 1; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0, mysql_init_command => 'SET SESSION wait_timeout=7' });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 5; ok(defined $dbh, "Connected to database"); ok(my $sth=$dbh->prepare("SHOW SESSION VARIABLES like 'wait_timeout'")); ok($sth->execute()); ok(my @fetchrow = $sth->fetchrow_array()); is($fetchrow[1],'7','session variable is 7'); $sth->finish(); $dbh->disconnect(); ��86_bug_36972.t��0000644��00000002365�15125143222�0006600 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use lib 't', '.'; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password); $\|= 1; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 0, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 11; ok(defined $dbh, "connecting"); # # Bug #42723: Binding server side integer parameters results in corrupt data # ok($dbh->do('DROP TABLE IF EXISTS dbd_mysql_t86'), "making slate clean"); ok($dbh->do('CREATE TABLE dbd_mysql_t86 (`i` int,`si` smallint,`ti` tinyint,`bi` bigint)'), "creating test table"); my $sth2; ok($sth2 = $dbh->prepare('INSERT INTO dbd_mysql_t86 VALUES (?,?,?,?)')); #bind test values ok($sth2->bind_param(1, 101, DBI::SQL_INTEGER), "binding int"); ok($sth2->bind_param(2, 102, DBI::SQL_SMALLINT), "binding smallint"); ok($sth2->bind_param(3, 103, DBI::SQL_TINYINT), "binding tinyint"); ok($sth2->bind_param(4, 104, DBI::SQL_INTEGER), "binding bigint"); ok($sth2->execute(), "inserting data"); is_deeply($dbh->selectall_arrayref('SELECT * FROM dbd_mysql_t86'), [[101, 102, 103, 104]]); ok ($dbh->do('DROP TABLE dbd_mysql_t86'), "cleaning up"); $dbh->disconnect(); ��rt86153-reconnect-fail-memory.t��0000644��00000003703�15125143222�0012162 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my $COUNT_CONNECT = 4000; # Number of connect/disconnect iterations my $have_storable; if (!$ENV{EXTENDED_TESTING}) { plan skip_all => "\$ENV{EXTENDED_TESTING} is not set\n"; } eval { require Proc::ProcessTable; }; if ($@) { plan skip_all => "module Proc::ProcessTable not installed \n"; } eval { require Storable }; $have_storable = $@ ? 0 : 1; my $have_pt_size = grep { $_ eq 'size' } Proc::ProcessTable->new('cache_ttys' => $have_storable)->fields; unless ($have_pt_size) { plan skip_all => "module Proc::ProcessTable does not support size attribute on current platform\n"; } plan tests => 3; sub size { my($p, $pt); $pt = Proc::ProcessTable->new('cache_ttys' => $have_storable); for $p (@{$pt->table()}) { if ($p->pid() == $$) { return $p->size(); } } die "Cannot find my own process?!?\n"; exit 0; } my ($size, $prev_size, $ok, $not_ok, $dbh2); note "Testing memory leaks in connect/disconnect\n"; $ok = 0; $not_ok = 0; $prev_size= undef; # run reconnect with a bad password for (my $i = 0; $i < $COUNT_CONNECT; $i++) { eval { $dbh2 = DBI->connect($test_dsn, $test_user, "$test_password ", { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($i % 100 == 99) { $size = size(); if (defined($prev_size)) { if ($size == $prev_size) { $ok++; } else { diag "$prev_size => $size" if $ENV{TEST_VERBOSE}; $not_ok++; } } else { $prev_size = $size; $size = size(); } $prev_size = $size; } } ok $ok, "\$ok $ok"; ok !$not_ok, "\$not_ok $not_ok"; cmp_ok $ok, '>', $not_ok, "\$ok $ok \$not_ok $not_ok"; ��16dbi-get_info.t��0000644��00000002414�15125143222�0007424 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use DBI::Const::GetInfoType; $\|= 1; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my $dbh; eval {$dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1})}; if ($@) { plan skip_all => "no database connection"; } # DBI documentation states: # Because some DBI methods make use of get_info(), drivers are strongly # encouraged to support at least the following very minimal set of # information types to ensure the DBI itself works properly # so let's test them here # DBMS_NAME and DBMS_VERSION are not static, all we can check is they are # there and they have some sane length my $dbms_name = $dbh->get_info( $GetInfoType{SQL_DBMS_NAME}); cmp_ok(length($dbms_name), '>', 4, 'SQL_DBMS_NAME'); my $dbms_ver = $dbh->get_info( $GetInfoType{SQL_DBMS_VER}); cmp_ok(length($dbms_ver), '>', 4, 'SQL_DBMS_VER'); # these variables are always the same for MySQL my %info = ( SQL_IDENTIFIER_QUOTE_CHAR => '`', SQL_CATALOG_NAME_SEPARATOR => '.', SQL_CATALOG_LOCATION => 1, ); for my $option ( keys %info ) { my $value = $dbh->get_info( $GetInfoType{$option}); is($value, $info{$option}, $option); } $dbh->disconnect(); done_testing; ��mysql.mtest��0000644��00000001703�15125143222�0006765 0��ustar�00��{ local $opt = { 'mysql_config' => 'mysql_config', 'testhost' => '', 'nocatchstderr' => 0, 'libs' => '-L/usr/lib64/mysql -lmysqlclient -lssl -lcrypto -lresolv -lm', 'testdb' => 'test', 'nofoundrows' => 0, 'testsocket' => '', 'testport' => '', 'ldflags' => '', 'version' => '8.0.40', 'testuser' => 'root', 'cflags' => '-I/usr/include/mysql -m64', 'testpassword' => '' }; $::test_host = $opt->{'testhost'}; $::test_port = $opt->{'testport'}; $::test_user = $opt->{'testuser'}; $::test_socket = $opt->{'testsocket'}; $::test_password = $opt->{'testpassword'}; $::test_db = $opt->{'testdb'}; $::test_dsn = "DBI:mysql:$::test_db"; $::test_dsn .= ";mysql_socket=$::test_socket" if $::test_socket; $::test_dsn .= ":$::test_host" if $::test_host; $::test_dsn .= ":$::test_port" if $::test_port; $::test_mysql_config = $opt->{'mysql_config'}; } 1; ��41int_min_max.t��0000644��00000014477�15125143222�0007412 0��ustar�00��use strict; use warnings; use bigint; use DBI; use Test::More; use lib 't', '.'; use Data::Dumper; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 1 });}; if ($@) { plan skip_all => "no database connection"; } if ($dbh->{mysql_serverversion} < 50002) { plan skip_all => "SKIP TEST: You must have MySQL version 5.0.2 and greater for this test to run"; } # nostrict tests + strict tests + init/tear down commands plan tests => (198 + 178 + 4) * 2; my $table = 'dbd_mysql_t41minmax'; # name of the table we will be using my $mode; # 'strict' or 'nostrict' corresponds to strict SQL mode sub test_int_type ($$$$) { my ($perl_type, $mysql_type, $min, $max) = @_; # Disable the warning text clobbering our output local $SIG{__WARN__} = sub { 1; }; # Create the table ok($dbh->do(qq{DROP TABLE IF EXISTS $table}), "removing $table"); ok($dbh->do(qq{ CREATE TABLE `$table` ( `id` int not null auto_increment, `val` $mysql_type, primary key (id) ) }), "creating minmax table for type $mysql_type"); my ($store, $retrieve); # statements my $read_value; # retrieved value ok($store = $dbh->prepare("INSERT INTO $table (val) VALUES (?)")); ok($retrieve = $dbh->prepare("SELECT val from $table where id=(SELECT MAX(id) FROM $table)")); ######################################## # Insert allowed min value ######################################## ok($store->bind_param( 1, $min->bstr(), $perl_type ), "binding minimal $mysql_type, mode=$mode"); ok($store->execute(), "inserting min data for type $mysql_type, mode=$mode"); ######################################## # Read it back and compare ######################################## ok{$retrieve->execute()}; ($read_value) = $retrieve->fetchrow_array(); cmp_ok($read_value, 'eq', $min, "retrieved minimal value for $mysql_type, mode=$mode"); ######################################## # Insert allowed max value ######################################## ok($store->bind_param( 1, $max->bstr(), $perl_type ), "binding maximal $mysql_type, mode=$mode"); ok($store->execute(), "inserting max data for type $mysql_type, mode=$mode"); ######################################## # Read it back and compare ######################################## ok{$retrieve->execute()}; ($read_value) = $retrieve->fetchrow_array(); cmp_ok($read_value, 'eq', $max, "retrieved maximal value for $mysql_type, mode=$mode"); ######################################## # Try to insert under the limit value ######################################## ok($store->bind_param( 1, ($min-1)->bstr(), $perl_type ), "binding less than minimal $mysql_type, mode=$mode"); if ($mode eq 'strict') { $@ = ''; eval{$store->execute()}; like($@, qr/Out of range value (?:adjusted )?for column 'val'/, "Error, you stored ".($min-1)." into $mysql_type, mode=$mode\n". Data::Dumper->Dump([$dbh->selectall_arrayref("SELECT * FROM $table")]). Data::Dumper->Dump([$dbh->selectall_arrayref("describe $table")]) ); } else { ok{$store->execute()}; ######################################## # Check that it was rounded correctly ######################################## ok{$retrieve->execute()}; ($read_value) = $retrieve->fetchrow_array(); cmp_ok($read_value, 'eq', $min, "retrieved minimal value for type $mysql_type, mode=$mode"); }; ######################################## # Try to insert over the limit value ######################################## ok($store->bind_param( 1, ($max+1)->bstr(), $perl_type ), "binding more than maximal $mysql_type, mode=$mode"); if ($mode eq 'strict') { $@ = ''; eval{$store->execute()}; like($@, qr/Out of range value (?:adjusted )?for column 'val'/, "Error, you stored ".($max+1)." into $mysql_type, mode=$mode\n". Data::Dumper->Dump([$dbh->selectall_arrayref("SELECT * FROM $table")]). Data::Dumper->Dump([$dbh->selectall_arrayref("describe $table")]) ); } else { ok{$store->execute()}; ######################################## # Check that it was rounded correctly ######################################## ok{$retrieve->execute()}; ($read_value) = $retrieve->fetchrow_array(); cmp_ok($read_value, 'eq', $max, "retrieved maximal value for type $mysql_type, mode=$mode"); }; } $dbh->disconnect; for my $mysql_server_prepare (0, 1) { $dbh= DBI->connect($test_dsn . ';mysql_server_prepare=' . $mysql_server_prepare, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 }); # Set strict SQL mode ok($dbh->do("SET SQL_MODE='STRICT_ALL_TABLES'"),"Enter strict SQL mode."); $mode = 'strict'; test_int_type(DBI::SQL_TINYINT, 'tinyint signed', -27, 27-1); test_int_type(DBI::SQL_TINYINT, 'tinyint unsigned', 0, 28-1); test_int_type(DBI::SQL_SMALLINT, 'smallint signed', -215, 215-1); test_int_type(DBI::SQL_SMALLINT, 'smallint unsigned', 0, 216-1); test_int_type(DBI::SQL_INTEGER, 'int signed', -231, 231-1); test_int_type(DBI::SQL_INTEGER, 'int unsigned', 0, 232-1); test_int_type(DBI::SQL_BIGINT, 'bigint signed', -263, 263-1); test_int_type(DBI::SQL_BIGINT, 'bigint unsigned', 0, 264-1); # Do not use strict SQL mode ok($dbh->do("SET SQL_MODE=''"),"Leave strict SQL mode."); $mode = 'nostrict'; test_int_type(DBI::SQL_TINYINT, 'tinyint signed', -27, 27-1); test_int_type(DBI::SQL_TINYINT, 'tinyint unsigned', 0, 28-1); test_int_type(DBI::SQL_SMALLINT, 'smallint signed', -215, 215-1); test_int_type(DBI::SQL_SMALLINT, 'smallint unsigned', 0, 216-1); test_int_type(DBI::SQL_INTEGER, 'int signed', -231, 231-1); test_int_type(DBI::SQL_INTEGER, 'int unsigned', 0, 232-1); test_int_type(DBI::SQL_BIGINT, 'bigint signed', -263, 263-1); test_int_type(DBI::SQL_BIGINT, 'bigint unsigned', 0, 264-1); ok ($dbh->do("DROP TABLE $table")); ok $dbh->disconnect; } ��40server_prepare_crash.t��0000644��00000004316�15125143222�0011302 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use vars qw($test_dsn $test_user $test_password); require "t/lib.pl"; my $dbh = eval { DBI->connect($test_dsn, $test_user, $test_password, { PrintError => 1, RaiseError => 1, AutoCommit => 0, mysql_server_prepare => 1, mysql_server_prepare_disable_fallback => 1 }) }; plan skip_all => "no database connection" if $@ or not $dbh; plan skip_all => "You must have MySQL version 4.1.3 and greater for this test to run" if $dbh->{mysql_clientversion} < 40103 or $dbh->{mysql_serverversion} < 40103; plan tests => 39; my $sth; ok $dbh->do("CREATE TEMPORARY TABLE t (i INTEGER NOT NULL, n LONGBLOB)"); ok $sth = $dbh->prepare("INSERT INTO t(i, n) VALUES(?, ?)"); ok $sth->execute(1, "x" x 10); ok $sth->execute(2, "x" x 100); ok $sth->execute(3, "x" x 1000); ok $sth->execute(4, "x" x 10000); ok $sth->execute(5, "x" x 100000); ok $sth->execute(6, "x" x 1000000); ok $sth->finish(); ok $sth = $dbh->prepare("SELECT * FROM t WHERE i=? AND n=?"); ok $sth->bind_param(2, "x" x 1000000); ok $sth->bind_param(1, "abcx", 12); ok $sth->execute(); ok $sth->bind_param(2, "a" x 1000000); ok $sth->bind_param(1, 1, 3); ok $sth->execute(); ok $sth->finish(); ok $sth = $dbh->prepare("SELECT * FROM t WHERE i=? AND n=?"); ok $sth->execute(); ok $sth->finish(); ok $sth = $dbh->prepare("SELECT 1 FROM t WHERE i = ?" . (" OR i = ?" x 10000)); ok $sth->execute((1) x (10001)); ok $sth->finish(); my $test; ok $sth = $dbh->prepare("SELECT i,n FROM t WHERE i = ?"); ok $sth->execute(1); ok $sth->fetchrow_arrayref(); ok $sth->execute(2); $test = map { $_ } 'a'; ok $sth->fetchrow_arrayref(); ok $sth->execute(3); $test = map { $_ } 'b' x 10000000; # try to reuse released memory ok $sth->fetchrow_arrayref(); ok $sth->execute(4); $test = map { $_ } 'cd' x 10000000; # try to reuse of released memory ok $sth->fetchrow_arrayref(); ok $sth->execute(5); $test = map { $_ } 'efg' x 10000000; # try to reuse of released memory ok $sth->fetchrow_arrayref(); ok $sth->execute(6); $test = map { $_ } 'hijk' x 10000000; # try to reuse of released memory ok $sth->fetchrow_arrayref(); ok $sth->finish(); ok $dbh->do("SELECT 1 FROM t WHERE i = ?" . (" OR i = ?" x 10000), {}, (1) x (10001)); ok $dbh->disconnect(); ��40blobs.t��0000644��00000003606�15125143222�0006200 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use vars qw($test_dsn $test_user $test_password); use lib '.', 't'; require 'lib.pl'; sub ShowBlob($) { my ($blob) = @_; my $b; for (my $i = 0; $i < 8; $i++) { if (defined($blob) && length($blob) > $i) { $b = substr($blob, $i32); } else { $b = ""; } note sprintf("%08lx %s\n", $i32, unpack("H64", $b)); } } my $dbh; my $charset= 'DEFAULT CHARSET=utf8'; eval {$dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1}) or ServerError() ;}; if ($@) { plan skip_all => "no database connection"; } else { plan tests => 14; } if (!MinimumVersion($dbh, '4.1')) { $charset= ''; } my $size= 128; ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t40blobs"), "Drop table if exists dbd_mysql_t40blobs"; my $create = <<EOT; CREATE TABLE dbd_mysql_t40blobs ( id INT(3) NOT NULL DEFAULT 0, name BLOB ) $charset EOT ok ($dbh->do($create)); my ($blob, $qblob) = ""; my $b = ""; for (my $j = 0; $j < 256; $j++) { $b .= chr($j); } for (1 .. $size) { $blob .= $b; } ok ($qblob = $dbh->quote($blob)); # Insert a row into the test table....... my ($query); $query = "INSERT INTO dbd_mysql_t40blobs VALUES(1, $qblob)"; ok ($dbh->do($query)); # Now, try SELECT'ing the row out. ok (my $sth = $dbh->prepare("SELECT * FROM dbd_mysql_t40blobs WHERE id = 1")); ok ($sth->execute); ok (my $row = $sth->fetchrow_arrayref); ok defined($row), "row returned defined"; is @$row, 2, "records from dbd_mysql_t40blobs returned 2"; is $$row[0], 1, 'id set to 1'; cmp_ok byte_string($$row[1]), 'eq', byte_string($blob), 'blob set equal to blob returned'; ShowBlob($blob), ShowBlob(defined($$row[1]) ? $$row[1] : ""); ok ($sth->finish); ok $dbh->do("DROP TABLE dbd_mysql_t40blobs"), "Drop table dbd_mysql_t40blobs"; ok $dbh->disconnect; ��gh360.t��0000644��00000001512�15125143222�0005554 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use lib 't', '.'; require 'lib.pl'; # https://github.com/perl5-dbi/DBD-mysql/issues/360 my ($dbhA, $dbhB); use vars qw($test_dsn $test_user $test_password); my $dsnA = $test_dsn . ';mysql_enable_utf8mb4=1'; eval {$dbhA = DBI->connect($dsnA, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1});}; if ($@) { diag $@; plan skip_all => "no database connection"; } my $dsnB = $test_dsn; $dsnB =~ s/DBI:mysql/DBI:mysql(mysql_enable_utf8mb4=1)/; eval {$dbhB = DBI->connect($dsnB . ';mysql_enable_utf8mb4=1', $test_user, $test_password, { RaiseError => 1, AutoCommit => 1});}; plan tests => 2; ok($dbhA->{mysql_enable_utf8mb4} == 1, 'mysql_enable_utf8mb4 == 1 with regular DSN'); ok($dbhB->{mysql_enable_utf8mb4} == 1, 'mysql_enable_utf8mb4 == 1 with driver DSN'); ��15reconnect.t��0000644��00000003057�15125143222�0007061 0��ustar�00��use strict; use warnings; use Test::More; use DBI; $\|= 1; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my $dbh; eval {$dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1})}; if ($@) { plan skip_all => "no database connection"; } plan tests => 34; for my $mysql_server_prepare (0, 1) { $dbh= DBI->connect("$test_dsn;mysql_server_prepare=$mysql_server_prepare;mysql_server_prepare_disable_fallback=1", $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 }); ok(defined $dbh, "Connected to database"); ok($dbh->{Active}, "checking for active handle"); ok($dbh->{mysql_auto_reconnect} = 1, "enabling reconnect"); ok($dbh->{AutoCommit} = 1, "enabling autocommit"); ok ($dbh->do("SET SESSION wait_timeout=2")); sleep(3); ok($dbh->do("SELECT 1"), "implicitly reconnecting handle with 'do'"); ok($dbh->{Active}, "checking for reactivated handle"); ok($dbh->disconnect(), "disconnecting active handle"); ok(!$dbh->{Active}, "checking for inactive handle"); ok($dbh->do("SELECT 1"), "implicitly reconnecting handle with 'do'"); ok($dbh->{Active}, "checking for reactivated handle"); ok(!($dbh->{AutoCommit} = 0), "disabling autocommit"); ok($dbh->disconnect(), "disconnecting active handle"); ok(!$dbh->{Active}, "checking for inactive handle"); ok( ! $dbh->ping(), 'dbh is disconnected and did not segv'); ok(!$dbh->do("SELECT 1"), "implicitly reconnecting handle with 'do'"); ok(!$dbh->{Active}, "checking for reactivated handle"); } ��rt50304-column_info_parentheses.t��0000644��00000003047�15125143222�0012662 0��ustar�00��use strict; use warnings; use DBI; use vars qw($test_dsn $test_user $test_password $state); require "t/lib.pl"; use Test::More; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 0, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } ok($dbh->do("DROP TABLE IF EXISTS dbd_mysql_rt50304_column_info")); my $create = <<EOC; CREATE TABLE dbd_mysql_rt50304_column_info ( id int(10)unsigned NOT NULL AUTO_INCREMENT, problem_column SET('','(Some Text)') DEFAULT NULL, regular_column SET('','Some Text') DEFAULT NULL, PRIMARY KEY (id), UNIQUE KEY id (id) ); EOC ok($dbh->do($create), "create table dbd_mysql_rt50304_column_info"); my $sth = $dbh->column_info(undef, undef, 'dbd_mysql_rt50304_column_info', 'problem_column'); my $info = $sth->fetchall_arrayref({}); is ( scalar @{$info->[0]->{mysql_values}}, 2, 'problem_column values'); is ( $info->[0]->{mysql_values}->[0], '', 'problem_column first value'); is ( $info->[0]->{mysql_values}->[1], '(Some Text)', 'problem_column second value'); $sth= $dbh->column_info(undef, undef, 'dbd_mysql_rt50304_column_info', 'regular_column'); $info = $sth->fetchall_arrayref({}); is ( scalar @{$info->[0]->{mysql_values}}, 2, 'regular_column values'); is ( $info->[0]->{mysql_values}->[0], '', 'regular_column first value'); is ( $info->[0]->{mysql_values}->[1], 'Some Text', 'regular_column second value'); ok($dbh->do("DROP TABLE dbd_mysql_rt50304_column_info")); ok($dbh->disconnect()); done_testing; ��10connect.t��0000644��00000005144�15125143222�0006524 0��ustar�00��use strict; use warnings; use Test::More ; use DBI; use DBI::Const::GetInfoType; $\|= 1; use vars qw($test_dsn $test_user $test_password $test_db); use lib 't', '.'; require 'lib.pl'; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { diag $@; plan skip_all => "no database connection"; } ok(defined $dbh, "Connected to database"); for my $attribute ( qw( mysql_clientinfo mysql_clientversion mysql_serverversion mysql_hostinfo mysql_serverinfo mysql_stat mysql_protoinfo ) ) { ok($dbh->{$attribute}, "Value of '$attribute'"); diag "$attribute is: ". $dbh->{$attribute}; } my $sql_dbms_ver = $dbh->get_info($GetInfoType{SQL_DBMS_VER}); ok($sql_dbms_ver, 'get_info SQL_DBMS_VER'); diag "SQL_DBMS_VER is $sql_dbms_ver"; my $driver_ver = $dbh->get_info($GetInfoType{SQL_DRIVER_VER}); like( $driver_ver, qr/^\d{2}\.\d{2}\.\d{4}$/, 'get_info SQL_DRIVER_VER like dd.dd.dddd' ); like($driver_ver, qr/^05\./, 'SQL_DRIVER_VER starts with "05." (update for 6.x)'); # storage engine function is @@storage_engine in up to 5.5.03 # at that version, @@default_storage_engine is introduced # http://dev.mysql.com/doc/refman/5.5/en/server-system-variables.html#sysvar_storage_engine # in MySQL Server 5.7.5 the old option is removed # http://dev.mysql.com/doc/refman/5.7/en/server-system-variables.html#sysvar_storage_engine my $storage_engine = $dbh->{mysql_serverversion} >= 50503 ? '@@default_storage_engine' : '@@storage_engine'; my $result = $dbh->selectall_arrayref('select ' . $storage_engine); my $default_storage_engine = $result->[0]->[0] \|\| 'unknown'; diag "Default storage engine is: $default_storage_engine"; my $info_hashref = $dbh->{mysql_dbd_stats}; ok($dbh->disconnect(), 'Disconnected'); ok( ! $dbh->ping(), 'dbh is disconnected and did not segv'); # dbi docs state: # The username and password can also be specified using the attributes # Username and Password, in which case they take precedence over the $username # and $password parameters. # see https://rt.cpan.org/Ticket/Display.html?id=89835 eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0, Username => '4yZ73s9qeECdWi', Password => '64heUGwAsVoNqo' });}; ok($@, 'Username and Password attributes override'); eval {$dbh= DBI->connect($test_dsn, '4yZ73s9qeECdWi', '64heUGwAsVoNqo', { RaiseError => 1, PrintError => 1, AutoCommit => 0, Username => $test_user, Password => $test_password });}; ok(!$@, 'Username and Password attributes override'); done_testing; ��50commit.t��0000644��00000004576�15125143222�0006377 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use lib 't', '.'; require 'lib.pl'; use vars qw($got_warning $test_dsn $test_user $test_password); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } sub catch_warning ($) { $got_warning = 1; } sub num_rows($$$) { my($dbh, $table, $num) = @_; my($sth, $got); if (!($sth = $dbh->prepare("SELECT * FROM dbd_mysql_t50commit"))) { return "Failed to prepare: err " . $dbh->err . ", errstr " . $dbh->errstr; } if (!$sth->execute) { return "Failed to execute: err " . $dbh->err . ", errstr " . $dbh->errstr; } $got = 0; while ($sth->fetchrow_arrayref) { ++$got; } if ($got ne $num) { return "Wrong result: Expected $num rows, got $got.\n"; } return ''; } plan tests => 22; ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t50commit"), "drop table if exists dbd_mysql_t50commit"; my $create =<<EOT; CREATE TABLE dbd_mysql_t50commit ( id INT(4) NOT NULL default 0, name VARCHAR(64) NOT NULL default '' ) ENGINE=InnoDB EOT ok $dbh->do($create), 'create dbd_mysql_t50commit'; ok !$dbh->{AutoCommit}, "\$dbh->{AutoCommit} not defined \|$dbh->{AutoCommit}\|"; $dbh->{AutoCommit} = 0; ok !$dbh->err; ok !$dbh->errstr; ok !$dbh->{AutoCommit}; ok $dbh->do("INSERT INTO dbd_mysql_t50commit VALUES (1, 'Jochen')"), "insert into dbd_mysql_t50commit (1, 'Jochen')"; my $msg; $msg = num_rows($dbh, 'dbd_mysql_t50commit', 1); ok !$msg; ok $dbh->rollback, 'rollback'; $msg = num_rows($dbh, 'dbd_mysql_t50commit', 0); ok !$msg; ok $dbh->do("DELETE FROM dbd_mysql_t50commit WHERE id = 1"), "delete from dbd_mysql_t50commit where id = 1"; $msg = num_rows($dbh, 'dbd_mysql_t50commit', 0); ok !$msg; ok $dbh->commit, 'commit'; $msg = num_rows($dbh, 'dbd_mysql_t50commit', 0); ok !$msg; # Check auto rollback after disconnect ok $dbh->do("INSERT INTO dbd_mysql_t50commit VALUES (1, 'Jochen')"); $msg = num_rows($dbh, 'dbd_mysql_t50commit', 1); ok !$msg; ok $dbh->disconnect; ok ($dbh = DBI->connect($test_dsn, $test_user, $test_password)); ok $dbh, "connected"; $msg = num_rows($dbh, 'dbd_mysql_t50commit', 0); ok !$msg; ok $dbh->{AutoCommit}, "\$dbh->{AutoCommit} $dbh->{AutoCommit}"; ok $dbh->do("DROP TABLE dbd_mysql_t50commit"); ��30insertfetch.t��0000644��00000002310�15125143222�0007403 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use DBI::Const::GetInfoType; use lib 't', '.'; require 'lib.pl'; $\|= 1; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } ok(defined $dbh, "Connected to database"); ok($dbh->do("CREATE TEMPORARY TABLE dbd_mysql_t30 (id INT(4), name VARCHAR(64))"), "creating table"); ok($dbh->do(" INSERT INTO dbd_mysql_t30 VALUES (1, 'Alligator Descartes'), (2, 'Tim Bunce') "), "loading data"); ok(my $info = $dbh->{mysql_info}, "mysql_info '" . $dbh->{mysql_info} . "'"); like($info, qr/^Records:\s\d/, 'mysql_info: Records'); like($info, qr/Duplicates:\s0\s/, 'mysql_info: Duplicates'); like($info, qr/Warnings: 0$/, 'mysql_info: Warnings'); ok( $dbh->do("DELETE FROM dbd_mysql_t30 WHERE id IN (1,2)"), "deleting from table dbd_mysql_t30" ); ok (my $sth= $dbh->prepare("SELECT * FROM dbd_mysql_t30 WHERE id = 1")); ok($sth->execute()); ok(not $sth->fetchrow_arrayref()); ok($sth->finish()); ok($dbh->disconnect()); done_testing; ��rt118977-zerofill.t��0000644��00000001177�15125143222�0007706 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use vars qw($test_dsn $test_user $test_password); require "t/lib.pl"; my $dbh = eval { DBI->connect($test_dsn, $test_user, $test_password, { PrintError => 1, RaiseError => 1 }) }; plan skip_all => "no database connection" if $@ or not $dbh; plan tests => 42; for my $mysql_server_prepare (0, 1) { $dbh->{mysql_server_prepare} = $mysql_server_prepare; ok $dbh->do("DROP TABLE IF EXISTS t"); ok $dbh->do("CREATE TEMPORARY TABLE t(id smallint(5) unsigned zerofill)"); ok $dbh->do("INSERT INTO t(id) VALUES(1)"); is $dbh->selectcol_arrayref("SELECT id FROM t")->[0], "00001"; } ��91errcheck.t��0000644��00000000745�15125143222�0006674 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 0, PrintError => 0, AutoCommit => 0 });}; if (!$dbh) { plan skip_all => "no database connection"; } plan tests => 1; $dbh->do( 'this should die' ); ok $DBI::errstr, 'error string should be set on a bad call'; $dbh->disconnect; ��rt85919-fetch-lost-connection.t��0000644��00000004511�15125143222�0012177 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use lib 't', '.'; use vars qw($test_dsn $test_user $test_password $mdriver); require 'lib.pl'; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 0, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } my $sth; my $ok = eval { note "Connecting...\n"; ok( $sth = $dbh->do('SET wait_timeout = 5'), 'set wait_timeout'); note "Sleeping...\n"; sleep 7; my $sql = 'SELECT 1'; if (1) { ok( $sth = $dbh->prepare($sql), 'prepare SQL'); ok( $sth->execute(), 'execute SQL'); my @res = $sth->fetchrow_array(); is ( $res[0], undef, 'no rows returned'); ok( $sth->finish(), 'finish'); $sth = undef; } else { note "Selecting...\n"; my @res = $dbh->selectrow_array($sql); } $dbh->disconnect(); $dbh = undef; 1; }; if (not $ok) { # if we're connected via a local socket we receive error 2006 # (CR_SERVER_GONE_ERROR) but if we're connected using TCP/IP we get # 2013 (CR_SERVER_LOST) # # as of 8.0.24 MySQL writes the reason the connection was closed # before closing it, so 4031 (ER_CLIENT_INTERACTION_TIMEOUT) is # now an valid return code if ($DBI::err == 2006) { pass("received error 2006 (CR_SERVER_GONE_ERROR)"); } elsif ($DBI::err == 2013) { pass("received error 2013 (CR_SERVER_LOST)"); } elsif ($DBI::err == 4031) { pass("received error 4031 (ER_CLIENT_INTERACTION_TIMEOUT)"); } else { fail('Should return error 2006 or 2013'); } eval { $sth->finish(); } if defined $sth; eval { $dbh->disconnect(); } if defined $dbh; } if (0) { # This causes the use=after-free crash in RT #97625. # different testcase by killing the service. which is of course # not doable in a general testscript and highly system dependent. system(qw(sudo service mysql start)); use DBI; my $dbh = DBI->connect("DBI:mysql:database=test:port=3306"); $dbh->{mysql_auto_reconnect} = 1; # without this is works my $select = sub { $dbh->do(q{SELECT 1}) for 1 .. 10; }; $select->(); system qw(sudo service mysql stop); $select->(); ok(1, "dbh did not crash on closed connection"); system(qw(sudo service mysql start)); } done_testing(); ��56connattr.t��0000644��00000003226�15125143222�0006734 0��ustar�00��#!/usr/bin/perl use strict; use warnings; use DBI; use DBI::Const::GetInfoType; use Test::More; use lib 't', '.'; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password $table); my $dbh; eval { $dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 0, AutoCommit => 0, mysql_conn_attrs => { foo => 'bar' }, } ); }; if ($@) { plan skip_all => "no database connection"; } my @pfenabled = $dbh->selectrow_array("show variables like 'performance_schema'"); if (!@pfenabled) { plan skip_all => 'performance schema not available'; } if ($pfenabled[1] ne 'ON') { plan skip_all => 'performance schema not enabled'; } if ($dbh->{mysql_clientversion} < 50606) { plan skip_all => 'client version should be 5.6.6 or later'; } eval {$dbh->do("select from performance_schema.session_connect_attrs where processlist_id=connection_id()");}; if ($@) { $dbh->disconnect(); plan skip_all => "no permission on performance_schema tables"; } plan tests => 8; my $rows = $dbh->selectall_hashref("select * from performance_schema.session_connect_attrs where processlist_id=connection_id()", "ATTR_NAME"); my $pid =$rows->{_pid}->{ATTR_VALUE}; cmp_ok $pid, '==', $$; my $progname =$rows->{program_name}->{ATTR_VALUE}; cmp_ok $progname, 'eq', $0; my $foo_attr =$rows->{foo}->{ATTR_VALUE}; cmp_ok $foo_attr, 'eq', 'bar'; for my $key ('_platform','_client_name','_client_version','_os') { my $row = $rows->{$key}; cmp_ok defined $row, '==', 1, "attribute $key"; } ok $dbh->disconnect; ��31insertid.t��0000644��00000004467�15125143222�0006726 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require "lib.pl"; my $dbh; eval{$dbh = DBI->connect($test_dsn, $test_user, $test_password, {RaiseError => 1});}; if ($@) { plan skip_all => "no database connection"; } plan tests => 21; SKIP: { skip 'SET @@auto_increment_offset needs MySQL >= 5.0.2', 2 unless $dbh->{mysql_serverversion} >= 50002; ok $dbh->do('SET @@auto_increment_offset = 1'); ok $dbh->do('SET @@auto_increment_increment = 1'); } my $create = <<EOT; CREATE TEMPORARY TABLE dbd_mysql_t31 ( id INT(3) PRIMARY KEY AUTO_INCREMENT NOT NULL, name VARCHAR(64)) EOT ok $dbh->do($create), "create dbd_mysql_t31"; my $query= "INSERT INTO dbd_mysql_t31 (name) VALUES (?)"; my $sth; ok ($sth= $dbh->prepare($query)); ok defined $sth; ok $sth->execute("Jochen"); is $sth->{mysql_insertid}, 1, "insert id == $sth->{mysql_insertid}"; is $dbh->{mysql_insertid}, 1, "insert id == $dbh->{mysql_insertid}"; is $dbh->last_insert_id(undef, undef, undef, undef), 1, "insert id == last_insert_id()"; ok $sth->execute("Patrick"); $dbh->ping(); SKIP: { skip 'using libmysqlclient 5.7 or up we now have an empty dbh insertid', 1, if ($dbh->{mysql_clientversion} >= 50700 && $dbh->{mysql_clientversion} < 50718) \|\| ($dbh->{mysql_clientversion} >= 60105 && $dbh->{mysql_clientversion} < 69999) \|\| $dbh->{mysql_clientversion} == 80000; is $dbh->last_insert_id(undef, undef, undef, undef), 2, "insert id == last_insert_id()"; } ok (my $sth2= $dbh->prepare("SELECT max(id) FROM dbd_mysql_t31")); ok defined $sth2; ok $sth2->execute(); my $max_id; ok ($max_id= $sth2->fetch()); ok defined $max_id; SKIP: { skip 'using libmysqlclient 5.7 below 5.7.18 we now have an empty dbh insertid', 1, if ($dbh->{mysql_clientversion} >= 50700 && $dbh->{mysql_clientversion} < 50718) \|\| ($dbh->{mysql_clientversion} >= 60105 && $dbh->{mysql_clientversion} < 69999) \|\| $dbh->{mysql_clientversion} == 80000; cmp_ok $dbh->{mysql_insertid}, '==', $max_id->[0], "dbh insert id $dbh->{'mysql_insertid'} == max(id) $max_id->[0] in dbd_mysql_t31"; } cmp_ok $sth->{mysql_insertid}, '==', $max_id->[0], "sth insert id $sth->{'mysql_insertid'} == max(id) $max_id->[0] in dbd_mysql_t31"; ok $sth->finish(); ok $sth2->finish(); ok $dbh->disconnect(); ��40nulls_prepare.t��0000644��00000004752�15125143222�0007755 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use lib 't', '.'; require 'lib.pl'; my ($row, $sth, $dbh); my ($table, $def, $rows, $errstr, $ret_ref); use vars qw($table $test_dsn $test_user $test_password); eval {$dbh = DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, AutoCommit => 1});}; if ($@) { plan skip_all => "no database connection", } ok(defined $dbh, "Connected to database"); ok($dbh->do("DROP TABLE IF EXISTS dbd_mysql_t40nullsprepare"), "Making slate clean"); my $create= <<EOSQL; CREATE TABLE dbd_mysql_t40nullsprepare ( id int, value0 varchar(10), value1 varchar(10), value2 varchar(10)) EOSQL ok($dbh->do($create), "creating test table for bug 49719"); my ($sth_insert, $sth_lookup); my $insert= 'INSERT INTO dbd_mysql_t40nullsprepare (id, value0, value1, value2) VALUES (?, ?, ?, ?)'; ok($sth_insert= $dbh->prepare($insert), "Prepare of insert"); my $select= "SELECT * FROM dbd_mysql_t40nullsprepare WHERE id = ?"; ok($sth_lookup= $dbh->prepare($select), "Prepare of query"); # Insert null value ok($sth_insert->bind_param(1, 42, DBI::SQL_WVARCHAR), "bind_param(1,42, SQL_WARCHAR)"); ok($sth_insert->bind_param(2, 102, DBI::SQL_WVARCHAR), "bind_param(2,102,SQL_WARCHAR"); ok($sth_insert->bind_param(3, undef, DBI::SQL_WVARCHAR), "bind_param(3, undef,SQL_WVARCHAR)"); ok($sth_insert->bind_param(4, 10004, DBI::SQL_WVARCHAR), "bind_param(4, 10004,SQL_WVARCHAR)"); ok($sth_insert->execute(), "Executing the first insert"); # Insert afterwards none null value # The bug would insert (DBD::MySQL-4.012) corrupted data.... # incorrect use of MYSQL_TYPE_NULL in prepared statement in dbdimp.c ok($sth_insert->bind_param(1, 43, DBI::SQL_WVARCHAR),"bind_param(1,43,SQL_WVARCHAR)"); ok($sth_insert->bind_param(2, 2002, DBI::SQL_WVARCHAR),"bind_param(2,2002,SQL_WVARCHAR)"); ok($sth_insert->bind_param(3, 20003, DBI::SQL_WVARCHAR),"bind_param(3,20003,SQL_WVARCHAR)"); ok($sth_insert->bind_param(4, 200004, DBI::SQL_WVARCHAR),"bind_param(4,200004,SQL_WVARCHAR)"); ok($sth_insert->execute(), "Executing the 2nd insert"); # verify ok($sth_lookup->execute(42), "Query for record of id = 42"); is_deeply($sth_lookup->fetchrow_arrayref(), [42, 102, undef, 10004]); ok($sth_lookup->execute(43), "Query for record of id = 43"); is_deeply($sth_lookup->fetchrow_arrayref(), [43, 2002, 20003, 200004]); ok($sth_insert->finish()); ok($sth_lookup->finish()); ok $dbh->do("DROP TABLE dbd_mysql_t40nullsprepare"); ok($dbh->disconnect(), "Testing disconnect"); done_testing; ��55utf8mb4.t��0000644��00000002055�15125143222�0006373 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } eval { $dbh->{PrintError} = 0; $dbh->do("SET NAMES 'utf8mb4'"); $dbh->{PrintError} = 1; 1; } or do { $dbh->disconnect(); plan skip_all => "no support for utf8mb4"; }; ok $dbh->do("CREATE TEMPORARY TABLE dbd_mysql_t55utf8mb4 (id SERIAL, val TEXT CHARACTER SET utf8mb4)"); my $sth = $dbh->prepare("INSERT INTO dbd_mysql_t55utf8mb4(val) VALUES('😈')"); $sth->execute(); my $query = "SELECT val, HEX(val) FROM dbd_mysql_t55utf8mb4 LIMIT 1"; $sth = $dbh->prepare($query) or die "$DBI::errstr"; ok $sth->execute; ok(my $ref = $sth->fetchrow_arrayref, 'fetch row'); ok($sth->finish, 'close sth'); cmp_ok $ref->[0], 'eq', "😈"; cmp_ok $ref->[1], 'eq', "F09F9888"; $dbh->disconnect(); done_testing; ��40catalog.t��0000644��00000024424�15125143222�0006512 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use lib '.', 't'; require 'lib.pl'; $\|= 1; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 1, mysql_server_prepare => 0 });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 78; ok(defined $dbh, "connecting"); my $sth; # # Bug #26604: foreign_key_info() implementation # # The tests for this are adapted from the Connector/J test suite. # SKIP: { skip "Server is too old to support INFORMATION_SCHEMA for foreign keys", 16 if !MinimumVersion($dbh, '5.0'); my $have_innodb = 0; if (!MinimumVersion($dbh, '5.6')) { my $dummy; ($dummy,$have_innodb)= $dbh->selectrow_array("SHOW VARIABLES LIKE 'have_innodb'") or DbiError($dbh->err, $dbh->errstr); } else { my $engines = $dbh->selectall_arrayref('SHOW ENGINES'); if (!$engines) { DbiError($dbh->err, $dbh->errstr); } else { STORAGE_ENGINE: for my $engine (@$engines) { next STORAGE_ENGINE if lc $engine->[0] ne 'innodb'; next STORAGE_ENGINE if lc $engine->[1] eq 'no'; $have_innodb = 1; } } } skip "Server doesn't support InnoDB, needed for testing foreign keys", 16 if !$have_innodb; ok($dbh->do(qq{DROP TABLE IF EXISTS child, parent}), "cleaning up"); ok($dbh->do(qq{CREATE TABLE parent(id INT NOT NULL, PRIMARY KEY (id)) ENGINE=INNODB})); ok($dbh->do(qq{CREATE TABLE child(id INT, parent_id INT, FOREIGN KEY (parent_id) REFERENCES parent(id) ON DELETE SET NULL) ENGINE=INNODB})); $sth= $dbh->foreign_key_info(undef, undef, 'parent', undef, undef, 'child'); my ($info)= $sth->fetchall_arrayref({}); is($info->[0]->{PKTABLE_NAME}, "parent"); is($info->[0]->{PKCOLUMN_NAME}, "id"); is($info->[0]->{FKTABLE_NAME}, "child"); is($info->[0]->{FKCOLUMN_NAME}, "parent_id"); $sth= $dbh->foreign_key_info(undef, undef, 'parent', undef, undef, undef); ($info)= $sth->fetchall_arrayref({}); is($info->[0]->{PKTABLE_NAME}, "parent"); is($info->[0]->{PKCOLUMN_NAME}, "id"); is($info->[0]->{FKTABLE_NAME}, "child"); is($info->[0]->{FKCOLUMN_NAME}, "parent_id"); $sth= $dbh->foreign_key_info(undef, undef, undef, undef, undef, 'child'); ($info)= $sth->fetchall_arrayref({}); is($info->[0]->{PKTABLE_NAME}, "parent"); is($info->[0]->{PKCOLUMN_NAME}, "id"); is($info->[0]->{FKTABLE_NAME}, "child"); is($info->[0]->{FKCOLUMN_NAME}, "parent_id"); ok($dbh->do(qq{DROP TABLE IF EXISTS child, parent}), "cleaning up"); }; # # table_info() tests # # These tests assume that no other tables name like 't_dbd_mysql_%' exist on # the server we are using for testing. # SKIP: { skip "Server can't handle tricky table names", 33 if !MinimumVersion($dbh, '4.1'); my $sth = $dbh->table_info("%", undef, undef, undef); is(scalar @{$sth->fetchall_arrayref()}, 0, "No catalogs expected"); $sth = $dbh->table_info(undef, "%", undef, undef); ok(scalar @{$sth->fetchall_arrayref()} > 0, "Some schemas expected"); $sth = $dbh->table_info(undef, undef, undef, "%"); ok(scalar @{$sth->fetchall_arrayref()} > 0, "Some table types expected"); ok($dbh->do(qq{DROP TABLE IF EXISTS t_dbd_mysql_t1, t_dbd_mysql_t11, t_dbd_mysql_t2, t_dbd_mysqlat2, `t_dbd_mysql_a'b`, `t_dbd_mysql_a``b`}), "cleaning up"); ok($dbh->do(qq{CREATE TABLE t_dbd_mysql_t1 (a INT)}) and $dbh->do(qq{CREATE TABLE t_dbd_mysql_t11 (a INT)}) and $dbh->do(qq{CREATE TABLE t_dbd_mysql_t2 (a INT)}) and $dbh->do(qq{CREATE TABLE t_dbd_mysqlat2 (a INT)}) and $dbh->do(qq{CREATE TABLE `t_dbd_mysql_a'b` (a INT)}) and $dbh->do(qq{CREATE TABLE `t_dbd_mysql_a``b` (a INT)}), "creating test tables"); # $base is our base table name, with the _ escaped to avoid extra matches my $esc = $dbh->get_info(14); # SQL_SEARCH_PATTERN_ESCAPE (my $base = "t_dbd_mysql_") =~ s/([_%])/$esc$1/g; # Test fetching info on a single table $sth = $dbh->table_info(undef, undef, $base . "t1", undef); my $info = $sth->fetchall_arrayref({}); is($info->[0]->{TABLE_CAT}, undef); is($info->[0]->{TABLE_NAME}, "t_dbd_mysql_t1"); is($info->[0]->{TABLE_TYPE}, "TABLE"); is(scalar @$info, 1, "one row expected"); # Test fetching info on a wildcard $sth = $dbh->table_info(undef, undef, $base . "t1%", undef); $info = $sth->fetchall_arrayref({}); is($info->[0]->{TABLE_CAT}, undef); is($info->[0]->{TABLE_NAME}, "t_dbd_mysql_t1"); is($info->[0]->{TABLE_TYPE}, "TABLE"); is($info->[1]->{TABLE_CAT}, undef); is($info->[1]->{TABLE_NAME}, "t_dbd_mysql_t11"); is($info->[1]->{TABLE_TYPE}, "TABLE"); is(scalar @$info, 2, "two rows expected"); # Test fetching info on a single table with escaped wildcards $sth = $dbh->table_info(undef, undef, $base . "t2", undef); $info = $sth->fetchall_arrayref({}); is($info->[0]->{TABLE_CAT}, undef); is($info->[0]->{TABLE_NAME}, "t_dbd_mysql_t2"); is($info->[0]->{TABLE_TYPE}, "TABLE"); is(scalar @$info, 1, "only one table expected"); # Test fetching info on a single table with ` in name $sth = $dbh->table_info(undef, undef, $base . "a`b", undef); $info = $sth->fetchall_arrayref({}); is($info->[0]->{TABLE_CAT}, undef); is($info->[0]->{TABLE_NAME}, "t_dbd_mysql_a`b"); is($info->[0]->{TABLE_TYPE}, "TABLE"); is(scalar @$info, 1, "only one table expected"); # Test fetching info on a single table with ' in name $sth = $dbh->table_info(undef, undef, $base . "a'b", undef); $info = $sth->fetchall_arrayref({}); is($info->[0]->{TABLE_CAT}, undef); is($info->[0]->{TABLE_NAME}, "t_dbd_mysql_a'b"); is($info->[0]->{TABLE_TYPE}, "TABLE"); is(scalar @$info, 1, "only one table expected"); # Test fetching our tables with a wildcard schema # NOTE: the performance of this could be bad if the mysql user we # are connecting as can see lots of databases. $sth = $dbh->table_info(undef, "%", $base . "%", undef); $info = $sth->fetchall_arrayref({}); is(scalar @$info, 5, "five tables expected"); # Check that tables() finds and escapes the tables named with quotes $info = [ $dbh->tables(undef, undef, $base . 'a%') ]; like($info->[0], qr/\.`t_dbd_mysql_a'b`$/, "table with single quote"); like($info->[1], qr/\.`t_dbd_mysql_a``b`$/, "table with back quote"); is(scalar @$info, 2, "two tables expected"); # Clean up ok($dbh->do(qq{DROP TABLE IF EXISTS t_dbd_mysql_t1, t_dbd_mysql_t11, t_dbd_mysql_t2, t_dbd_mysqlat2, `t_dbd_mysql_a'b`, `t_dbd_mysql_a``b`}), "cleaning up"); }; # # view-related table_info tests # SKIP: { skip "Server is too old to support views", 19 if !MinimumVersion($dbh, '5.0'); # # Bug #26603: (one part) support views in table_info() # ok($dbh->do(qq{DROP VIEW IF EXISTS bug26603_v1}) and $dbh->do(qq{DROP TABLE IF EXISTS bug26603_t1}), "cleaning up"); ok($dbh->do(qq{CREATE TABLE bug26603_t1 (a INT)}) and $dbh->do(qq{CREATE VIEW bug26603_v1 AS SELECT * FROM bug26603_t1}), "creating resources"); # Try without any table type specified $sth = $dbh->table_info(undef, undef, "bug26603%"); my $info = $sth->fetchall_arrayref({}); is($info->[0]->{TABLE_NAME}, "bug26603_t1"); is($info->[0]->{TABLE_TYPE}, "TABLE"); is($info->[1]->{TABLE_NAME}, "bug26603_v1"); is($info->[1]->{TABLE_TYPE}, "VIEW"); is(scalar @$info, 2, "two rows expected"); # Just get the view $sth = $dbh->table_info(undef, undef, "bug26603%", "VIEW"); $info = $sth->fetchall_arrayref({}); is($info->[0]->{TABLE_NAME}, "bug26603_v1"); is($info->[0]->{TABLE_TYPE}, "VIEW"); is(scalar @$info, 1, "one row expected"); # Just get the table $sth = $dbh->table_info(undef, undef, "bug26603%", "TABLE"); $info = $sth->fetchall_arrayref({}); is($info->[0]->{TABLE_NAME}, "bug26603_t1"); is($info->[0]->{TABLE_TYPE}, "TABLE"); is(scalar @$info, 1, "one row expected"); # Get both tables and views $sth = $dbh->table_info(undef, undef, "bug26603%", "'TABLE','VIEW'"); $info = $sth->fetchall_arrayref({}); is($info->[0]->{TABLE_NAME}, "bug26603_t1"); is($info->[0]->{TABLE_TYPE}, "TABLE"); is($info->[1]->{TABLE_NAME}, "bug26603_v1"); is($info->[1]->{TABLE_TYPE}, "VIEW"); is(scalar @$info, 2, "two rows expected"); ok($dbh->do(qq{DROP VIEW IF EXISTS bug26603_v1}) and $dbh->do(qq{DROP TABLE IF EXISTS bug26603_t1}), "cleaning up"); }; # # column_info() tests # SKIP: { ok($dbh->do(qq{DROP TABLE IF EXISTS t1}), "cleaning up"); ok($dbh->do(qq{CREATE TABLE t1 (a INT PRIMARY KEY AUTO_INCREMENT, b INT, `a_` INT, `a'b` INT, bar INT )}), "creating table"); # # Bug #26603: (one part) add mysql_is_autoincrement # $sth= $dbh->column_info(undef, undef, "t1", 'a'); my ($info)= $sth->fetchall_arrayref({}); is($info->[0]->{mysql_is_auto_increment}, 1); $sth= $dbh->column_info(undef, undef, "t1", 'b'); ($info)= $sth->fetchall_arrayref({}); is($info->[0]->{mysql_is_auto_increment}, 0); # # Test that wildcards and odd names are handled correctly # $sth= $dbh->column_info(undef, undef, "t1", "a%"); ($info)= $sth->fetchall_arrayref({}); is(scalar @$info, 3); $sth= $dbh->column_info(undef, undef, "t1", "a" . $dbh->get_info(14) . "_"); ($info)= $sth->fetchall_arrayref({}); is(scalar @$info, 1); $sth= $dbh->column_info(undef, undef, "t1", "a'b"); ($info)= $sth->fetchall_arrayref({}); is(scalar @$info, 1); # # The result set is ordered by TABLE_CAT, TABLE_SCHEM, TABLE_NAME and ORDINAL_POSITION. # $sth= $dbh->column_info(undef, undef, "t1", undef); ($info)= $sth->fetchall_arrayref({}); is(join(' ++ ', map { $_->{COLUMN_NAME} } @{$info}), "a ++ b ++ a_ ++ a'b ++ bar"); ok($dbh->do(qq{DROP TABLE IF EXISTS t1}), "cleaning up"); $dbh->disconnect(); }; $dbh->disconnect(); ��89async-method-check.t��0000644��00000013731�15125143222�0010562 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use DBI::Const::GetInfoType; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my @common_safe_methods = qw/ can err errstr parse_trace_flag parse_trace_flags private_attribute_info trace trace_msg visit_child_handles /; my @db_safe_methods = (@common_safe_methods, qw/ clone mysql_async_ready /); my @db_unsafe_methods = qw/ data_sources do last_insert_id selectrow_array selectrow_arrayref selectrow_hashref selectall_arrayref selectall_hashref selectcol_arrayref prepare prepare_cached commit rollback begin_work ping get_info table_info column_info primary_key_info primary_key foreign_key_info statistics_info tables type_info_all type_info quote quote_identifier /; my @st_safe_methods = qw/ fetchrow_arrayref fetch fetchrow_array fetchrow_hashref fetchall_arrayref fetchall_hashref finish rows /; my @st_unsafe_methods = qw/ bind_param bind_param_inout bind_param_array execute execute_array execute_for_fetch bind_col bind_columns /; my %dbh_args = ( can => ['can'], parse_trace_flag => ['SQL'], parse_trace_flags => ['SQL'], trace_msg => ['message'], visit_child_handles => [sub { }], quote => ['string'], quote_identifier => ['Users'], do => ['SELECT 1'], last_insert_id => [undef, undef, undef, undef], selectrow_array => ['SELECT 1'], selectrow_arrayref => ['SELECT 1'], selectrow_hashref => ['SELECT 1'], selectall_arrayref => ['SELECT 1'], selectall_hashref => ['SELECT 1', '1'], selectcol_arrayref => ['SELECT 1'], prepare => ['SELECT 1'], prepare_cached => ['SELECT 1'], get_info => [$GetInfoType{'SQL_DBMS_NAME'}], column_info => [undef, undef, '%', '%'], primary_key_info => [undef, undef, 'async_test'], primary_key => [undef, undef, 'async_test'], foreign_key_info => [undef, undef, 'async_test', undef, undef, undef], statistics_info => [undef, undef, 'async_test', 0, 1], ); my %sth_args = ( fetchall_hashref => [1], bind_param => [1, 1], bind_param_inout => [1, \(my $scalar = 1), 64], bind_param_array => [1, [1]], execute_array => [{ ArrayTupleStatus => [] }, [1]], execute_for_fetch => [sub { undef } ], bind_col => [1, \(my $scalar2 = 1)], bind_columns => [\(my $scalar3)], ); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 0, PrintError => 0, AutoCommit => 0 });}; if (!$dbh) { plan skip_all => "no database connection"; } plan tests => 2 * @db_safe_methods + 4 * @db_unsafe_methods + 7 * @st_safe_methods + 3 * @common_safe_methods + 2 * @st_unsafe_methods + 3; $dbh->do(<<SQL); CREATE TEMPORARY TABLE async_test ( value INTEGER ) SQL foreach my $method (@db_safe_methods) { $dbh->do('SELECT 1', { async => 1 }); my $args = $dbh_args{$method} \|\| []; $dbh->$method(@$args); ok !$dbh->errstr, "Testing method '$method' on DBD::mysql::db during asynchronous operation"; ok defined($dbh->mysql_async_result); } $dbh->do('SELECT 1', { async => 1 }); ok defined($dbh->mysql_async_result); foreach my $method (@db_unsafe_methods) { $dbh->do('SELECT 1', { async => 1 }); my $args = $dbh_args{$method} \|\| []; my @values = $dbh->$method(@$args); # some methods complain unless they're called in list context like $dbh->errstr, qr/Calling a synchronous function on an asynchronous handle/, "Testing method '$method' on DBD::mysql::db during asynchronous operation"; ok defined($dbh->mysql_async_result); } foreach my $method (@common_safe_methods) { my $sth = $dbh->prepare('SELECT 1', { async => 1 }); $sth->execute; my $args = $dbh_args{$method} \|\| []; # they're common methods, so this should be ok! $sth->$method(@$args); ok !$sth->errstr, "Testing method '$method' on DBD::mysql::db during asynchronous operation"; ok defined($sth->mysql_async_result); ok defined($sth->mysql_async_result); } foreach my $method (@st_safe_methods) { my $sth = $dbh->prepare('SELECT 1', { async => 1 }); $sth->execute; my $args = $sth_args{$method} \|\| []; $sth->$method(@$args); ok !$sth->errstr, "Testing method '$method' on DBD::mysql::st during asynchronous operation"; # statement safe methods cache async result and mysql_async_result can be called multiple times ok defined($sth->mysql_async_result), "Testing DBD::mysql::st method '$method' for async result"; ok defined($sth->mysql_async_result), "Testing DBD::mysql::st method '$method' for async result"; } foreach my $method (@st_safe_methods) { my $sync_sth = $dbh->prepare('SELECT 1'); my $async_sth = $dbh->prepare('SELECT 1', { async => 1 }); $dbh->do('SELECT 1', { async => 1 }); ok !$sync_sth->execute; ok $sync_sth->errstr; ok !$async_sth->execute; ok $async_sth->errstr; $dbh->mysql_async_result; } foreach my $method (@db_unsafe_methods) { my $sth = $dbh->prepare('SELECT 1', { async => 1 }); $sth->execute; ok !$dbh->do('SELECT 1', { async => 1 }); ok $dbh->errstr; $sth->mysql_async_result; } foreach my $method (@st_unsafe_methods) { my $sth = $dbh->prepare('SELECT value FROM async_test WHERE value = ?', { async => 1 }); $sth->execute(1); my $args = $sth_args{$method} \|\| []; my @values = $sth->$method(@$args); like $dbh->errstr, qr/Calling a synchronous function on an asynchronous handle/, "Testing method '$method' on DBD::mysql::st during asynchronous operation"; ok(defined $sth->mysql_async_result); } my $sth = $dbh->prepare('SELECT 1', { async => 1 }); $sth->execute; ok defined($sth->mysql_async_ready); ok $sth->mysql_async_result; undef $sth; $dbh->disconnect; ��40numrows.t��0000644��00000003734�15125143222�0006613 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my ($dbh, $sth, $aref); eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 30; ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t40numrows"); my $create= <<EOT; CREATE TABLE dbd_mysql_t40numrows ( id INT(4) NOT NULL DEFAULT 0, name varchar(64) NOT NULL DEFAULT '' ) EOT ok $dbh->do($create), "CREATE TABLE dbd_mysql_t40numrows"; ok $dbh->do("INSERT INTO dbd_mysql_t40numrows VALUES( 1, 'Alligator Descartes' )"), 'inserting first row'; ok ($sth = $dbh->prepare("SELECT * FROM dbd_mysql_t40numrows WHERE id = 1")); ok $sth->execute; is $sth->rows, 1, '\$sth->rows should be 1'; ok ($aref= $sth->fetchall_arrayref); is scalar @$aref, 1, 'Verified rows should be 1'; ok $sth->finish; ok $dbh->do("INSERT INTO dbd_mysql_t40numrows VALUES( 2, 'Jochen Wiedmann' )"), 'inserting second row'; ok ($sth = $dbh->prepare("SELECT * FROM dbd_mysql_t40numrows WHERE id >= 1")); ok $sth->execute; is $sth->rows, 2, '\$sth->rows should be 2'; ok ($aref= $sth->fetchall_arrayref); is scalar @$aref, 2, 'Verified rows should be 2'; ok $sth->finish; ok $dbh->do("INSERT INTO dbd_mysql_t40numrows VALUES(3, 'Tim Bunce')"), "inserting third row"; ok ($sth = $dbh->prepare("SELECT * FROM dbd_mysql_t40numrows WHERE id >= 2")); ok $sth->execute; is $sth->rows, 2, 'rows should be 2'; ok ($aref= $sth->fetchall_arrayref); is scalar @$aref, 2, 'Verified rows should be 2'; ok $sth->finish; ok ($sth = $dbh->prepare("SELECT * FROM dbd_mysql_t40numrows")); ok $sth->execute; is $sth->rows, 3, 'rows should be 3'; ok ($aref= $sth->fetchall_arrayref); is scalar @$aref, 3, 'Verified rows should be 3'; ok $dbh->do("DROP TABLE dbd_mysql_t40numrows"), "drop table dbd_mysql_t40numrows"; ok $dbh->disconnect; ��05dbcreate.t��0000644��00000001370�15125143222�0006645 0��ustar�00��use strict; use warnings; use Test::More ; use DBI; $\|= 1; use vars qw($test_user $test_password $test_db $test_dsn); use lib 't', '.'; require 'lib.pl'; # remove database from DSN $test_dsn =~ s/^DBI:mysql:([^:;]+)([:;]?)/DBI:mysql:$2/; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { diag $@; plan skip_all => "no database connection"; } plan tests => 2; ok defined $dbh, "Connected to database"; eval{ $dbh->do("CREATE DATABASE IF NOT EXISTS $test_db") }; if($@) { diag "No permission to '$test_db' database on '$test_dsn' for user '$test_user'"; } else { diag "Database '$test_db' accessible"; } ok $dbh->disconnect(); ��50chopblanks.t��0000644��00000005471�15125143222�0007226 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use lib 't', '.'; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 1 });}; if ($@) { plan skip_all => "no database connection"; } if ($dbh->{mysql_serverversion} < 50000) { plan skip_all => "You must have MySQL version 5.0.0 and greater for this test to run"; } for my $mysql_server_prepare (0, 1) { eval {$dbh= DBI->connect("$test_dsn;mysql_server_prepare=$mysql_server_prepare;mysql_server_prepare_disable_fallback=1", $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 1 });}; ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t50chopblanks"), "drop table if exists dbd_mysql_t50chopblanks"; my $create= <<EOT; CREATE TABLE dbd_mysql_t50chopblanks ( id INT(4), c_varchar VARCHAR(64), c_text TEXT, c_tinytext TINYTEXT, c_mediumtext MEDIUMTEXT, c_longtext LONGTEXT, b_blob BLOB, b_tinyblob TINYBLOB, b_mediumblob MEDIUMBLOB, b_longblob LONGBLOB ) EOT ok $dbh->do($create), "create table dbd_mysql_t50chopblanks"; my @fields = qw(c_varchar c_text c_tinytext c_mediumtext c_longtext b_blob b_tinyblob b_mediumblob b_longblob); my $numfields = scalar @fields; my $fieldlist = join(', ', @fields); ok (my $sth= $dbh->prepare("INSERT INTO dbd_mysql_t50chopblanks (id, $fieldlist) VALUES (".('?, ' x $numfields)."?)")); ok (my $sth2= $dbh->prepare("SELECT $fieldlist FROM dbd_mysql_t50chopblanks WHERE id = ?")); my $rows; $rows = [ [1, ''], [2, ' '], [3, ' a b c '], [4, 'blah'] ]; for my $ref (@$rows) { my ($id, $value) = @$ref; ok $sth->execute($id, ($value) x $numfields), "insert into dbd_mysql_t50chopblanks values ($id ".(", '$value'" x $numfields).")"; ok $sth2->execute($id), "select $fieldlist from dbd_mysql_t50chopblanks where id = $id"; # First try to retrieve without chopping blanks. $sth2->{'ChopBlanks'} = 0; my $ret_ref = []; ok ($ret_ref = $sth2->fetchrow_arrayref); for my $i (0 .. $#{$ret_ref}) { cmp_ok $ret_ref->[$i], 'eq', $value, "NoChopBlanks: $fields[$i] should not have blanks chopped"; } # Now try to retrieve with chopping blanks. $sth2->{'ChopBlanks'} = 1; ok $sth2->execute($id); $ret_ref = []; ok ($ret_ref = $sth2->fetchrow_arrayref); for my $i (0 .. $#{$ret_ref}) { my $choppedvalue = $value; my $character_field = ($fields[$i] =~ /^c/); $choppedvalue =~ s/\s+$// if $character_field; # only chop character, not binary cmp_ok $ret_ref->[$i], 'eq', $choppedvalue, "ChopBlanks: $fields[$i] should ".($character_field ? "" : "not ")."have blanks chopped"; } } ok $sth->finish; ok $sth2->finish; ok $dbh->do("DROP TABLE dbd_mysql_t50chopblanks"), "drop dbd_mysql_t50chopblanks"; ok $dbh->disconnect; } done_testing; ��88async-multi-stmts.t��0000644��00000001643�15125143222�0010527 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use DBI::Const::GetInfoType; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 0, PrintError => 0, AutoCommit => 0 });}; if (!$dbh) { plan skip_all => "no database connection"; } plan tests => 8; $dbh->do(<<SQL); CREATE TEMPORARY TABLE async_test ( value INTEGER ); SQL my $sth0 = $dbh->prepare('INSERT INTO async_test VALUES(0)', { async => 1 }); my $sth1 = $dbh->prepare('INSERT INTO async_test VALUES(1)', { async => 1 }); $sth0->execute; ok !defined($sth1->mysql_async_ready); ok $sth1->errstr; ok !defined($sth1->mysql_async_result); ok $sth1->errstr; ok defined($sth0->mysql_async_ready); ok !$sth1->errstr; ok defined($sth0->mysql_async_result); ok !$sth1->errstr; undef $sth0; undef $sth1; $dbh->disconnect; ��20createdrop.t��0000644��00000001351�15125143222�0007220 0��ustar�00��use strict; use warnings; use Test::More; use DBI; $\|= 1; use vars qw($test_dsn $test_user $test_password); use lib 't', '.'; require 'lib.pl'; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 4; ok(defined $dbh, "Connected to database"); ok($dbh->do("DROP TABLE IF EXISTS dbd_mysql_t20createdrop"), "making slate clean"); ok($dbh->do("CREATE TABLE dbd_mysql_t20createdrop (id INT(4), name VARCHAR(64))"), "creating dbd_mysql_t20createdrop"); ok($dbh->do("DROP TABLE dbd_mysql_t20createdrop"), "dropping created dbd_mysql_t20createdrop"); $dbh->disconnect(); ��99compression.t��0000644��00000002057�15125143222�0007455 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use lib 't', '.'; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { diag $@; plan skip_all => "no database connection"; } if ($dbh->{mysql_serverversion} < 80000) { diag $dbh->{mysql_serverversion}; plan skip_all => "test requires 8.x or newer"; } foreach my $compression ( "zlib", "zstd", "0", "1" ) { my ($dbh, $sth, $row); eval {$dbh = DBI->connect($test_dsn . ";mysql_compression=$compression", $test_user, $test_password, { RaiseError => 1, AutoCommit => 1});}; ok ($sth= $dbh->prepare("SHOW SESSION STATUS LIKE 'Compression_algorithm'")); ok $sth->execute(); ok ($row= $sth->fetchrow_arrayref); my $exp = $compression; if ($exp eq "1") { $exp = "zlib" }; if ($exp eq "0") { $exp = "" }; cmp_ok $row->[1], 'eq', $exp, "\$row->[1] eq $exp"; ok $sth->finish; } plan tests => 45; ��25lockunlock.t��0000644��00000002753�15125143222�0007250 0��ustar�00��use strict; use warnings; use Test::More; use DBI; use lib 't', '.'; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 13; my $create= <<EOT; CREATE TABLE dbd_mysql_t25lockunlock ( id int(4) NOT NULL default 0, name varchar(64) NOT NULL default '' ) EOT ok $dbh->do("DROP TABLE IF EXISTS dbd_mysql_t25lockunlock"), "drop table if exists dbd_mysql_t25lockunlock"; ok $dbh->do($create), "create table dbd_mysql_t25lockunlock"; ok $dbh->do("LOCK TABLES dbd_mysql_t25lockunlock WRITE"), "lock table dbd_mysql_t25lockunlock"; ok $dbh->do("INSERT INTO dbd_mysql_t25lockunlock VALUES(1, 'Alligator Descartes')"), "Insert "; ok $dbh->do("DELETE FROM dbd_mysql_t25lockunlock WHERE id = 1"), "Delete"; my $sth; eval {$sth= $dbh->prepare("SELECT FROM dbd_mysql_t25lockunlock WHERE id = 1")}; ok !$@, "Prepare of select"; ok defined($sth), "Prepare of select"; ok $sth->execute , "Execute"; my ($row, $errstr); $errstr= ''; $row = $sth->fetchrow_arrayref; $errstr= $sth->errstr; ok !defined($row), "Fetch should have failed"; ok !defined($errstr), "Fetch should have failed"; ok $dbh->do("UNLOCK TABLES"), "Unlock tables"; ok $dbh->do("DROP TABLE dbd_mysql_t25lockunlock"), "Drop table dbd_mysql_t25lockunlock"; ok $dbh->disconnect, "Disconnecting"; ��43count_params.t��0000644��00000003670�15125143222�0007576 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use lib 't', '.'; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password); my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } if (!MinimumVersion($dbh, '4.1') ) { plan skip_all => "SKIP TEST: You must have MySQL version 4.1 and greater for this test to run"; } plan tests => 17; ok ($dbh->do("DROP TABLE IF EXISTS dbd_mysql_t43count_params")); my $create = <<EOT; CREATE TABLE dbd_mysql_t43count_params ( id int(4) NOT NULL default 0, name varchar(100) default '' ) EOT ok ($dbh->do($create)); ok (my $sth = $dbh->prepare("INSERT INTO dbd_mysql_t43count_params (name, id)" . " VALUES ('Charles de Batz de Castelmore, comte d\\'Artagnan', ?)")); ok ($sth->execute(1)); ok ($sth = $dbh->prepare("INSERT INTO dbd_mysql_t43count_params (name, id)" . " VALUES ('Charles de Batz de Castelmore, comte d\\'Artagnan', 2)")); ok ($sth->execute()); ok ($sth = $dbh->prepare("INSERT INTO dbd_mysql_t43count_params (name, id) VALUES (?, ?)")); ok ($sth->execute("Charles de Batz de Castelmore, comte d\\'Artagnan", 3)); ok ($sth = $dbh->prepare("INSERT INTO dbd_mysql_t43count_params (id, name)" . " VALUES (?, 'Charles de Batz de Castelmore, comte d\\'Artagnan')")); ok ($sth->execute(1)); ok ($sth = $dbh->prepare("INSERT INTO dbd_mysql_t43count_params (id, name)" . " VALUES (2, 'Charles de Batz de Castelmore, comte d\\'Artagnan')")); ok ($sth->execute()); ok ($sth = $dbh->prepare("INSERT INTO dbd_mysql_t43count_params (id, name) VALUES (?, ?)")); ok ($sth->execute(3, "Charles de Batz de Castelmore, comte d\\'Artagnan")); ok ($dbh->do("DROP TABLE dbd_mysql_t43count_params")); ok $sth->finish; ok $dbh->disconnect; ��40listfields.t��0000644��00000004345�15125143222�0007242 0��ustar�00��use strict; use warnings; use DBI; use Test::More; use vars qw($COL_NULLABLE $test_dsn $test_user $test_password); use lib '.', 't'; require 'lib.pl'; use vars qw($test_dsn $test_user $test_password); my $quoted; my $create; my $dbh; eval {$dbh= DBI->connect($test_dsn, $test_user, $test_password, { RaiseError => 1, PrintError => 1, AutoCommit => 0 });}; if ($@) { plan skip_all => "no database connection"; } plan tests => 25; $dbh->{mysql_server_prepare}= 0; $create = <<EOC; CREATE TEMPORARY TABLE dbd_mysql_40listfields ( id INT(4) NOT NULL, name VARCHAR(64), key id (id) ) EOC ok $dbh->do($create), "create table dbd_mysql_40listfields"; ok $dbh->table_info(undef,undef,'dbd_mysql_40listfields'), "table info for dbd_mysql_40listfields"; ok $dbh->column_info(undef,undef,'dbd_mysql_40listfields','%'), "column_info for dbd_mysql_40listfields"; my $sth= $dbh->column_info(undef,undef,"this_does_not_exist",'%'); ok $sth, "\$sth defined"; ok !$sth->err(), "not error"; $sth = $dbh->prepare("SELECT * FROM dbd_mysql_40listfields"); ok $sth, "prepare succeeded"; ok $sth->execute, "execute select"; my $res; $res = $sth->{'NUM_OF_FIELDS'}; ok $res, "$sth->{NUM_OF_FIELDS} defined"; is $res, 2, "\$res $res == 2"; my $ref = $sth->{'NAME'}; ok $ref, "\$sth->{NAME} defined"; cmp_ok $$ref[0], 'eq', 'id', "$$ref[0] eq 'id'"; cmp_ok $$ref[1], 'eq', 'name', "$$ref[1] eq 'name'"; $ref = $sth->{'NULLABLE'}; ok $ref, "nullable"; ok !($$ref[0] xor (0 & $COL_NULLABLE)); ok !($$ref[1] xor (1 & $COL_NULLABLE)); $ref = $sth->{TYPE}; cmp_ok $ref->[0], 'eq', DBI::SQL_INTEGER(), "SQL_INTEGER"; cmp_ok $ref->[1], 'eq', DBI::SQL_VARCHAR(), "SQL_VARCHAR"; $sth = $dbh->prepare("SELECT * FROM dbd_mysql_40listfields"); if (!$sth) { die "Error:" . $dbh->errstr . "\n"; } if (!$sth->execute) { die "Error:" . $sth->errstr . "\n"; } ok ($sth= $dbh->prepare("DROP TABLE dbd_mysql_40listfields")); ok($sth->execute); ok (! defined $sth->{'NUM_OF_FIELDS'}); $quoted = eval { $dbh->quote(0, DBI::SQL_INTEGER()) }; ok (!$@); cmp_ok $quoted, 'eq', '0', "equals '0'"; $quoted = eval { $dbh->quote('abc', DBI::SQL_VARCHAR()) }; ok (!$@); cmp_ok $quoted, 'eq', "\'abc\'", "equals 'abc'"; ok($dbh->disconnect()); ��119_incr_parse_utf8.t��0000644��00000004324�15125143236�0010423 0��ustar�00��use strict; use warnings; use Test::More; use utf8; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; plan skip_all => "not for older version of JSON::PP" if JSON->backend->isa('JSON::PP') && JSON->backend->VERSION < 4.07; use Encode; use charnames qw< :full >; plan tests => 24; use vars qw< @vs >; ############################################################ ### These first tests mimic the ones in `t/001_utf8.t` ### ############################################################ scalar eval { JSON->new->allow_nonref (1)->utf8 (1)->incr_parse ('"ü"') }; like $@, qr/malformed UTF-8/; ok (JSON->new->allow_nonref (1)->incr_parse ('"ü"') eq "ü"); ok (JSON->new->allow_nonref (1)->incr_parse ('"\u00fc"') eq "ü"); ok (JSON->new->allow_nonref (1)->incr_parse ('"\ud801\udc02' . "\x{10204}\"") eq "\x{10402}\x{10204}"); ok (JSON->new->allow_nonref (1)->incr_parse ('"\"\n\\\\\r\t\f\b"') eq "\"\012\\\015\011\014\010"); my $JSON_TXT = <<JSON_TXT; { "a": "1" } { "b": "\N{BULLET}" } { "c": "3" } JSON_TXT ####################### ### With '->utf8' ### ####################### @vs = eval { JSON->new->utf8->incr_parse( $JSON_TXT ) }; like $@, qr/Wide character in subroutine entry/; @vs = eval { JSON->new->utf8->incr_parse( encode 'UTF-8' => $JSON_TXT ) }; ok( !$@ ); ok( scalar @vs == 3 ); is_deeply( \@vs, [ { a => "1" }, { b => "\N{BULLET}" }, { c => "3" } ] ); is_deeply( $vs[0], { a => "1" } ); is_deeply( $vs[1], { b => "\N{BULLET}" } ); is_deeply( $vs[2], { c => "3" } ); # Double-Encoded => "You Get What You Ask For" @vs = eval { JSON->new->utf8->incr_parse( encode 'UTF-8' => ( encode 'UTF-8' => $JSON_TXT ) ) }; ok( !$@ ); ok( scalar @vs == 3 ); is_deeply( \@vs, [ { a => "1" }, { b => "\x{E2}\x{80}\x{A2}" }, { c => "3" } ] ); is_deeply( $vs[0], { a => "1" } ); is_deeply( $vs[1], { b => "\x{E2}\x{80}\x{A2}" } ); is_deeply( $vs[2], { c => "3" } ); ########################## ### Without '->utf8' ### ########################## @vs = eval { JSON->new->incr_parse( $JSON_TXT ) }; ok( !$@ ); ok( scalar @vs == 3 ); is_deeply( \@vs, [ { a => "1" }, { b => "\N{BULLET}" }, { c => "3" } ] ); is_deeply( $vs[0], { a => "1" } ); is_deeply( $vs[1], { b => "\N{BULLET}" } ); is_deeply( $vs[2], { c => "3" } ); ��e00_func.t��0000644��00000000467�15125143236�0006341 0��ustar�00�� use Test::More; use strict; BEGIN { plan tests => 2 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; ######################### my $json = JSON->new; my $js = 'abc'; is(to_json($js, {allow_nonref => 1}), '"abc"'); is(from_json('"abc"', {allow_nonref => 1}), 'abc'); ��118_boolean_values.t��0000644��00000007070�15125143236�0010326 0��ustar�00��use strict; use warnings; use Test::More; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; BEGIN { plan skip_all => "requires Perl 5.008 or later" if $] < 5.008 } BEGIN { plan skip_all => "requires JSON::XS 4 compat backend" if ($JSON::BackendModulePP and eval $JSON::BackendModulePP->VERSION < 3) or ($JSON::BackendModule eq 'Cpanel::JSON::XS') or ($JSON::BackendModule eq 'JSON::XS' and $JSON::BackendModule->VERSION < 4); } package # Dummy::True; Dummy::True:: = JSON::PP::Boolean::; package # Dummy::False; Dummy::False:: = JSON::PP::Boolean::; package main; my $dummy_true = bless \(my $dt = 1), 'Dummy::True'; my $dummy_false = bless \(my $df = 0), 'Dummy::False'; my @tests = ([$dummy_true, $dummy_false, 'Dummy::True', 'Dummy::False']); # extra boolean classes if (eval "require boolean; 1") { push @tests, [boolean::true(), boolean::false(), 'boolean', 'boolean', 1]; } if (eval "require JSON; 1") { push @tests, [JSON::true(), JSON::false(), 'JSON::PP::Boolean', 'JSON::PP::Boolean']; push @tests, [JSON->boolean(11), JSON->boolean(undef), 'JSON::PP::Boolean', 'JSON::PP::Boolean']; push @tests, [JSON::boolean(11), JSON::boolean(undef), 'JSON::PP::Boolean', 'JSON::PP::Boolean']; } if (eval "require Data::Bool; 1") { push @tests, [Data::Bool::true(), Data::Bool::false(), 'Data::Bool::Impl', 'Data::Bool::Impl']; } if (eval "require Types::Serialiser; 1") { push @tests, [Types::Serialiser::true(), Types::Serialiser::false(), 'Types::Serialiser::BooleanBase', 'Types::Serialiser::BooleanBase']; } plan tests => 15 * @tests; my $json = JSON->new; for my $test (@tests) { my ($true, $false, $true_class, $false_class, $incompat) = @$test; my $ret = $json->boolean_values($false, $true); is $ret => $json, "returns the same object"; my ($new_false, $new_true) = $json->get_boolean_values; ok defined $new_true, "new true class is defined"; ok defined $new_false, "new false class is defined"; ok $new_true->isa($true_class), "new true class is $true_class"; ok $new_false->isa($false_class), "new false class is $false_class"; SKIP: { skip "$true_class is not compatible with JSON::PP::Boolean", 2 if $incompat; ok $new_true->isa('JSON::PP::Boolean'), "new true class is also JSON::PP::Boolean"; ok $new_false->isa('JSON::PP::Boolean'), "new false class is also JSON::PP::Boolean"; } my $should_true = $json->allow_nonref(1)->decode('true'); ok $should_true->isa($true_class), "JSON true turns into a $true_class object"; my $should_false = $json->allow_nonref(1)->decode('false'); ok $should_false->isa($false_class), "JSON false turns into a $false_class object"; SKIP: { skip "$true_class is not compatible with JSON::PP::Boolean", 2 if $incompat; my $should_true_json = eval { $json->allow_nonref(1)->encode($new_true); }; is $should_true_json => 'true', "A $true_class object turns into JSON true"; my $should_false_json = eval { $json->allow_nonref(1)->encode($new_false); }; is $should_false_json => 'false', "A $false_class object turns into JSON false"; } $ret = $json->boolean_values(); is $ret => $json, "returns the same object"; ok !$json->get_boolean_values, "reset boolean values"; $should_true = $json->allow_nonref(1)->decode('true'); ok $should_true->isa('JSON::PP::Boolean'), "JSON true turns into a JSON::PP::Boolean object"; $should_false = $json->allow_nonref(1)->decode('false'); ok $should_false->isa('JSON::PP::Boolean'), "JSON false turns into a JSON::PP::Boolean object"; } ��109_encode.t��0000644��00000003220�15125143236�0006556 0��ustar�00��# # decode on Perl 5.005, 5.6, 5.8 or later # use strict; use warnings; use Test::More; BEGIN { plan tests => 7 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } my $isASCII = ord "A" == 65; use JSON; no utf8; my $json = JSON->new->allow_nonref; # U+00B6 chosen because it works on both ASCII and EBCDIC is($json->encode("¶"), q\|"¶"\|); # as is $json->ascii; if ($] < 5.008) { is($json->encode("\xb6"), q\|"\u00b6"\|); # latin1 is($json->encode("\xc2\xb6"), q\|"\u00c2\u00b6"\|); # utf8 is($json->encode("¶"), q\|"\u00c2\u00b6"\|); # utf8 is($json->encode('あ'), q\|"\u00e3\u0081\u0082"\|); } else { is($json->encode("\xb6"), q\|"\u00b6"\|); # latin1 if (ord "A" == 65) { is($json->encode("\xc2\xb6"), q\|"\u00c2\u00b6"\|); # utf8 is($json->encode("¶"), q\|"\u00c2\u00b6"\|); # utf8 is($json->encode('あ'), q\|"\u00e3\u0081\u0082"\|); } else { if (ord '^' == 95) { # EBCDIC 1047 is($json->encode("\x80\x65"), q\|"\u0080\u0065"\|); # utf8 is($json->encode("¶"), q\|"\u0080\u0065"\|); # utf8 } else { # Assume EBCDIC 037 is($json->encode("\x78\x64"), q\|"\u0078\u0064"\|); # utf8 is($json->encode("¶"), q\|"\u0078\u0064"\|); # utf8 } is($json->encode('あ'), (q\|"\u00ce\u0043\u0043"\|)); } } if ($] >= 5.006) { is($json->encode(chr hex 3042 ), q\|"\u3042"\|); is($json->encode(chr hex 12345 ), q\|"\ud808\udf45"\|); } else { is($json->encode(chr hex 3042 ), $json->encode(chr 66)); is($json->encode(chr hex 12345 ), $json->encode(chr 69)); } ��18_json_checker.t��0000644��00000007554�15125143236�0007713 0��ustar�00��# copied over from JSON::XS and modified to use JSON # use the testsuite from http://www.json.org/JSON_checker/ # except for fail18.json, as we do not support a depth of 20 (but 16 and 32). use strict; no warnings; use Test::More; BEGIN { plan tests => 38 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; # emulate JSON_checker default config my $json = JSON->new->utf8->max_depth(32)->canonical; my $vax_float = (pack("d",1) =~ /^[\x80\x10]\x40/); binmode DATA; for (;;) { $/ = "\n# "; chomp (my $test = <DATA>) or last; $/ = "\n"; my $name = <DATA>; if ($vax_float && $name =~ /pass1.json/) { $test =~ s/\b23456789012E66\b/23456789012E20/; } if (my $perl = eval { $json->decode ($test) }) { ok ($name =~ /^pass/, $name); is ($json->encode ($json->decode ($json->encode ($perl))), $json->encode ($perl)); } else { ok ($name =~ /^fail/, "$name ($@)"); } } __DATA__ {"Extra value after close": true} "misplaced quoted value" # fail10.json {"Illegal expression": 1 + 2} # fail11.json {"Illegal invocation": alert()} # fail12.json {"Numbers cannot have leading zeroes": 013} # fail13.json {"Numbers cannot be hex": 0x14} # fail14.json ["Illegal backslash escape: \x15"] # fail15.json [\naked] # fail16.json ["Illegal backslash escape: \017"] # fail17.json [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[["Too deep"]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]] # fail18.json {"Missing colon" null} # fail19.json ["Unclosed array" # fail2.json {"Double colon":: null} # fail20.json {"Comma instead of colon", null} # fail21.json ["Colon instead of comma": false] # fail22.json ["Bad value", truth] # fail23.json ['single quote'] # fail24.json [" tab character in string "] # fail25.json ["tab\ character\ in\ string\ "] # fail26.json ["line break"] # fail27.json ["line\ break"] # fail28.json [0e] # fail29.json {unquoted_key: "keys must be quoted"} # fail3.json [0e+] # fail30.json [0e+-1] # fail31.json {"Comma instead if closing brace": true, # fail32.json ["mismatch"} # fail33.json ["extra comma",] # fail4.json ["double extra comma",,] # fail5.json [ , "<-- missing value"] # fail6.json ["Comma after the close"], # fail7.json ["Extra close"]] # fail8.json {"Extra comma": true,} # fail9.json [ "JSON Test Pattern pass1", {"object with 1 member":["array with 1 element"]}, {}, [], -42, true, false, null, { "integer": 1234567890, "real": -9876.543210, "e": 0.123456789e-12, "E": 1.234567890E+34, "": 23456789012E66, "zero": 0, "one": 1, "space": " ", "quote": "\"", "backslash": "\\", "controls": "\b\f\n\r\t", "slash": "/ & \/", "alpha": "abcdefghijklmnopqrstuvwyz", "ALPHA": "ABCDEFGHIJKLMNOPQRSTUVWYZ", "digit": "0123456789", "0123456789": "digit", "special": "`1~!@#$%^&()_+-={':[,]}\|;.</>?", "hex": "\u0123\u4567\u89AB\uCDEF\uabcd\uef4A", "true": true, "false": false, "null": null, "array":[ ], "object":{ }, "address": "50 St. James Street", "url": "http://www.JSON.org/", "comment": "// / <!-- --", "# -- --> /": " ", " s p a c e d " :[1,2 , 3 , 4 , 5 , 6 ,7 ],"compact":[1,2,3,4,5,6,7], "jsontext": "{\"object with 1 member\":[\"array with 1 element\"]}", "quotes": "" \u0022 %22 0x22 034 "", "\/\\\"\uCAFE\uBABE\uAB98\uFCDE\ubcda\uef4A\b\f\n\r\t`1~!@#$%^&()_+-=[]{}\|;:',./<>?" : "A key can be any string" }, 0.5 ,98.6 , 99.44 , 1066, 1e1, 0.1e1, 1e-1, 1e00,2e+00,2e-00 ,"rosebud"] # pass1.json [[[[[[[[[[[[[[[[[[["Not too deep"]]]]]]]]]]]]]]]]]]] # pass2.json { "JSON Test Pattern pass3": { "The outermost value": "must be an object or array.", "In this test": "It is an object." } } # pass3.json ��rt_122270_old_xs_boolean.t��0000644��00000001553�15125143236�0011250 0��ustar�00��# copied over from JSON::XS and modified to use JSON use strict; use warnings; use Test::More; BEGIN { plan tests => 10 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use utf8; use JSON; SKIP: { skip "no JSON::XS < 3", 5 unless eval { require JSON::XS; JSON::XS->VERSION < 3 }; my $false = JSON::XS::false(); ok (JSON::is_bool $false); ok (++$false == 1); ok (!JSON::is_bool $false); ok (!JSON::is_bool "JSON::Boolean"); ok (!JSON::is_bool {}); # GH-34 } SKIP: { skip "no Types::Serialiser 0.01", 5 unless eval { require JSON::XS; JSON::XS->VERSION(3.00); require Types::Serialiser; Types::Serialiser->VERSION == 0.01 }; my $false = JSON::XS::false(); ok (JSON::is_bool $false); ok (++$false == 1); ok (!JSON::is_bool $false); ok (!JSON::is_bool "JSON::Boolean"); ok (!JSON::is_bool {}); # GH-34 } ��x17_strange_overload.t��0000644��00000000744�15125143236�0010775 0��ustar�00��use strict; use Test::More; BEGIN { plan tests => 2 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= 1; } SKIP: { skip "for JSON::XS 3.x. cimpatible. Please see to Changes.", 2; eval q{ use JSON::XS; use JSON (); }; skip "can't use JSON::XS.", 2, if $@; skip "JSON::XS version < " . JSON->require_xs_version, 2 if JSON::XS->VERSION < JSON->require_xs_version; is("" . JSON::XS::true(), 'true'); is("" . JSON::true(), 'true'); } ��01_utf8.t��0000644��00000002465�15125143236�0006130 0��ustar�00��# copied over from JSON::XS and modified to use JSON use strict; use warnings; use Test::More; BEGIN { plan tests => 9 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use utf8; use JSON; my $pilcrow_utf8 = (ord "^" == 0x5E) ? "\xc2\xb6" # 8859-1 : (ord "^" == 0x5F) ? "\x80\x65" # CP 1024 : "\x78\x64"; # assume CP 037 is (JSON->new->allow_nonref (1)->utf8 (1)->encode ("¶"), "\"$pilcrow_utf8\""); is (JSON->new->allow_nonref (1)->encode ("¶"), "\"¶\""); is (JSON->new->allow_nonref (1)->ascii (1)->utf8 (1)->encode (chr 0x8000), '"\u8000"'); is (JSON->new->allow_nonref (1)->ascii (1)->utf8 (1)->pretty (1)->encode (chr 0x10402), "\"\\ud801\\udc02\"\n"); eval { JSON->new->allow_nonref (1)->utf8 (1)->decode ('"¶"') }; ok $@ =~ /malformed UTF-8/; is (JSON->new->allow_nonref (1)->decode ('"¶"'), "¶"); is (JSON->new->allow_nonref (1)->decode ('"\u00b6"'), "¶"); is (JSON->new->allow_nonref (1)->decode ('"\ud801\udc02' . "\x{10204}\""), "\x{10402}\x{10204}"); my $controls = (ord "^" == 0x5E) ? "\012\\\015\011\014\010" : (ord "^" == 0x5F) ? "\025\\\015\005\014\026" # CP 1024 : "\045\\\015\005\014\026"; # assume CP 037 is (JSON->new->allow_nonref (1)->decode ('"\"\n\\\\\r\t\f\b"'), "\"$controls"); ��116_incr_parse_fixed.t��0000644��00000000726�15125143236�0010633 0��ustar�00��use strict; use warnings; use Test::More tests => 4; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my $json = JSON->new->allow_nonref(1); my @vs = $json->incr_parse('"a\"bc'); ok( not scalar(@vs) ); @vs = $json->incr_parse('"'); is( $vs[0], "a\"bc" ); $json = JSON->new->allow_nonref(0); @vs = $json->incr_parse('"a\"bc'); ok( not scalar(@vs) ); @vs = eval { $json->incr_parse('"') }; ok($@ =~ qr/JSON text must be an object or array/); ��06_pc_pretty.t��0000644��00000002403�15125143236�0007250 0��ustar�00��# copied over from JSON::PC and modified to use JSON # copied over from JSON::XS and modified to use JSON use strict; use warnings; use Test::More; BEGIN { plan tests => 9 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my ($js,$obj,$json); my $pc = JSON->new; $obj = {foo => "bar"}; $js = $pc->encode($obj); is($js,q\|{"foo":"bar"}\|); $obj = [10, "hoge", {foo => "bar"}]; $pc->pretty (1); $js = $pc->encode($obj); is($js,q\|[ 10, "hoge", { "foo" : "bar" } ] \|); $obj = { foo => [ {a=>"b"}, 0, 1, 2 ] }; $pc->pretty(0); $js = $pc->encode($obj); is($js,q\|{"foo":[{"a":"b"},0,1,2]}\|); $obj = { foo => [ {a=>"b"}, 0, 1, 2 ] }; $pc->pretty(1); $js = $pc->encode($obj); is($js,q\|{ "foo" : [ { "a" : "b" }, 0, 1, 2 ] } \|); $obj = { foo => [ {a=>"b"}, 0, 1, 2 ] }; $pc->pretty(0); $js = $pc->encode($obj); is($js,q\|{"foo":[{"a":"b"},0,1,2]}\|); $obj = {foo => "bar"}; $pc->indent(1); is($pc->encode($obj), qq\|{\n "foo":"bar"\n}\n\|, "nospace"); $pc->space_after(1); is($pc->encode($obj), qq\|{\n "foo": "bar"\n}\n\|, "after"); $pc->space_before(1); is($pc->encode($obj), qq\|{\n "foo" : "bar"\n}\n\|, "both"); $pc->space_after(0); is($pc->encode($obj), qq\|{\n "foo" :"bar"\n}\n\|, "before"); ��22_comment_at_eof.t��0000644��00000002676�15125143236�0010230 0��ustar�00��# copied over from JSON::XS and modified to use JSON # the original test case was provided by IKEGAMI@cpan.org use strict; use warnings; use Test::More tests => 13; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; use Data::Dumper qw( Dumper ); sub decoder { my ($str) = @_; my $json = JSON->new->relaxed; $json->incr_parse($_[0]); my $rv; if (!eval { $rv = $json->incr_parse(); 1 }) { $rv = "died with $@"; } local $Data::Dumper::Useqq = 1; local $Data::Dumper::Terse = 1; local $Data::Dumper::Indent = 0; return Dumper($rv); } is( decoder( "[]" ), '[]', 'array baseline' ); is( decoder( " []" ), '[]', 'space ignored before array' ); is( decoder( "\n[]" ), '[]', 'newline ignored before array' ); is( decoder( "# foo\n[]" ), '[]', 'comment ignored before array' ); is( decoder( "# fo[o\n[]"), '[]', 'comment ignored before array' ); is( decoder( "# fo]o\n[]"), '[]', 'comment ignored before array' ); is( decoder( "[# fo]o\n]"), '[]', 'comment ignored inside array' ); is( decoder( "" ), 'undef', 'eof baseline' ); is( decoder( " " ), 'undef', 'space ignored before eof' ); is( decoder( "\n" ), 'undef', 'newline ignored before eof' ); is( decoder( "#,foo\n" ), 'undef', 'comment ignored before eof' ); is( decoder( "# []o\n" ), 'undef', 'comment ignored before eof' ); is( decoder(qq/#\n[#foo\n"#\\n"#\n]/), '["#\n"]', 'array and string in multiple lines' ); ��112_upgrade.t��0000644��00000000700�15125143236�0006742 0��ustar�00��use strict; use warnings; use Test::More; BEGIN { plan tests => 3 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my $json = JSON->new->allow_nonref->utf8; my $str = '\\u00b6'; my $value = $json->decode( '"\\u00b6"' ); #use Devel::Peek; #Dump( $value ); is( $value, chr 0xb6 ); ok( utf8::is_utf8( $value ) ); eval { $json->decode( '"' . chr(0xb6) . '"' ) }; ok( $@ =~ /malformed UTF-8 character in JSON string/ ); ��xe19_xs_and_suportbypp.t��0000644��00000001134�15125143236�0011363 0��ustar�00��# https://rt.cpan.org/Public/Bug/Display.html?id=52847 use strict; use Test::More; BEGIN { plan tests => 2 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= 1; } use JSON -support_by_pp; SKIP: { skip "can't use JSON::XS.", 2, unless( JSON->backend->is_xs ); my $json = JSON->new->allow_barekey; for (1..2) { is_deeply( test($json, q!{foo:"foo"}! ), {foo=>'foo'} ); JSON->new->allow_singlequote(0); } } sub test { my ($coder, $str) = @_; my $rv; return $rv if eval { $rv = $coder->decode($str); 1 }; chomp( my $e = $@ ); return "died with \"$e\""; }; ��rt_122270_is_bool_for_obsolete_xs_boolean.t��0000644��00000001553�15125143236�0014662 0��ustar�00��# copied over from JSON::XS and modified to use JSON use strict; use warnings; use Test::More; BEGIN { plan tests => 10 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use utf8; use JSON; SKIP: { skip "no JSON::XS < 3", 5 unless eval { require JSON::XS; JSON::XS->VERSION < 3 }; my $false = JSON::XS::false(); ok (JSON::is_bool $false); ok (++$false == 1); ok (!JSON::is_bool $false); ok (!JSON::is_bool "JSON::Boolean"); ok (!JSON::is_bool {}); # GH-34 } SKIP: { skip "no Types::Serialiser 0.01", 5 unless eval { require JSON::XS; JSON::XS->VERSION(3.00); require Types::Serialiser; Types::Serialiser->VERSION == 0.01 }; my $false = JSON::XS::false(); ok (JSON::is_bool $false); ok (++$false == 1); ok (!JSON::is_bool $false); ok (!JSON::is_bool "JSON::Boolean"); ok (!JSON::is_bool {}); # GH-34 } ��08_pc_base.t��0000644��00000004221�15125143236�0006635 0��ustar�00��use Test::More; # copied over from JSON::PC and modified to use JSON # copied over from JSON::XS and modified to use JSON use strict; use warnings; BEGIN { plan tests => 20 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my ($js,$obj); my $pc = JSON->new; $js = q\|{}\|; $obj = $pc->decode($js); $js = $pc->encode($obj); is($js,'{}', '{}'); $js = q\|[]\|; $obj = $pc->decode($js); $js = $pc->encode($obj); is($js,'[]', '[]'); $js = q\|{"foo":"bar"}\|; $obj = $pc->decode($js); is($obj->{foo},'bar'); $js = $pc->encode($obj); is($js,'{"foo":"bar"}', '{"foo":"bar"}'); $js = q\|{"foo":""}\|; $obj = $pc->decode($js); $js = $pc->encode($obj); is($js,'{"foo":""}', '{"foo":""}'); $js = q\|{"foo":" "}\|; $obj = $pc->decode($js); $js = $pc->encode($obj); is($js,'{"foo":" "}' ,'{"foo":" "}'); $js = q\|{"foo":"0"}\|; $obj = $pc->decode($js); $js = $pc->encode($obj); is($js,'{"foo":"0"}',q\|{"foo":"0"} - autoencode (default)\|); $js = q\|{"foo":"0 0"}\|; $obj = $pc->decode($js); $js = $pc->encode($obj); is($js,'{"foo":"0 0"}','{"foo":"0 0"}'); $js = q\|[1,2,3]\|; $obj = $pc->decode($js); is($obj->[1],2); $js = $pc->encode($obj); is($js,'[1,2,3]'); $js = q\|{"foo":{"bar":"hoge"}}\|; $obj = $pc->decode($js); is($obj->{foo}->{bar},'hoge'); $js = $pc->encode($obj); is($js,q\|{"foo":{"bar":"hoge"}}\|); $js = q\|[{"foo":[1,2,3]},-0.12,{"a":"b"}]\|; $obj = $pc->decode($js); $js = $pc->encode($obj); is($js,q\|[{"foo":[1,2,3]},-0.12,{"a":"b"}]\|); $obj = ["\x01"]; is($js = $pc->encode($obj),'["\\u0001"]'); $obj = $pc->decode($js); is($obj->[0],"\x01"); $obj = ["\e"]; is($js = $pc->encode($obj), (ord("A") == 65) ? '["\\u001b"]' : '["\\u0027"]'); $obj = $pc->decode($js); is($obj->[0],"\e"); $js = '{"id":"}'; eval q{ $pc->decode($js) }; like($@, qr/unexpected end/i); $obj = { foo => sub { "bar" } }; eval q{ $js = $pc->encode($obj) }; like($@, qr/JSON can only/i, 'invalid value (coderef)'); #$obj = { foo => bless {}, "Hoge" }; #eval q{ $js = $pc->encode($obj) }; #like($@, qr/JSON can only/i, 'invalid value (blessd object)'); $obj = { foo => \$js }; eval q{ $js = $pc->encode($obj) }; like($@, qr/cannot encode reference/i, 'invalid value (ref)'); ��xe12_boolean.t��0000644��00000001053�15125143236�0007210 0��ustar�00�� use strict; use Test::More; BEGIN { plan tests => 4 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= 1; } use JSON -support_by_pp; SKIP: { skip "can't use JSON::XS.", 4, unless( JSON->backend->is_xs ); my $json = new JSON; my $bool = $json->allow_nonref->decode('true'); # it's normal isa_ok( $bool, 'JSON::PP::Boolean' ); is( $json->encode([ JSON::true ]), '[true]' ); # make XS non support flag enable! $bool = $json->allow_singlequote->decode('true'); isa_ok( $bool, 'JSON::PP::Boolean' ); is( $json->encode([ JSON::true ]), '[true]' ); } __END__ ��x02_error.t��0000644��00000005204�15125143236�0006556 0��ustar�00��use strict; use Test::More; BEGIN { plan tests => 31 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= 1; } local $^W; use utf8; use JSON; SKIP: { skip "can't use JSON::XS.", 31, unless( JSON->backend->is_xs ); eval { JSON->new->encode ([\-1]) }; ok $@ =~ /cannot encode reference/; eval { JSON->new->encode ([\undef]) }; ok $@ =~ /cannot encode reference/; eval { JSON->new->encode ([\2]) }; ok $@ =~ /cannot encode reference/; eval { JSON->new->encode ([\{}]) }; ok $@ =~ /cannot encode reference/; eval { JSON->new->encode ([\[]]) }; ok $@ =~ /cannot encode reference/; eval { JSON->new->encode ([\\1]) }; ok $@ =~ /cannot encode reference/; eval { JSON->new->allow_nonref (1)->decode ('"\u1234\udc00"') }; ok $@ =~ /missing high /; eval { JSON->new->allow_nonref->decode ('"\ud800"') }; ok $@ =~ /missing low /; eval { JSON->new->allow_nonref (1)->decode ('"\ud800\u1234"') }; ok $@ =~ /surrogate pair /; eval { JSON->new->allow_nonref (0)->decode ('null') }; ok $@ =~ /allow_nonref/; eval { JSON->new->allow_nonref (1)->decode ('+0') }; ok $@ =~ /malformed/; eval { JSON->new->allow_nonref->decode ('.2') }; ok $@ =~ /malformed/; eval { JSON->new->allow_nonref (1)->decode ('bare') }; ok $@ =~ /malformed/; eval { JSON->new->allow_nonref->decode ('naughty') }; ok $@ =~ /null/; eval { JSON->new->allow_nonref (1)->decode ('01') }; ok $@ =~ /leading zero/; eval { JSON->new->allow_nonref->decode ('00') }; ok $@ =~ /leading zero/; eval { JSON->new->allow_nonref (1)->decode ('-0.') }; ok $@ =~ /decimal point/; eval { JSON->new->allow_nonref->decode ('-0e') }; ok $@ =~ /exp sign/; eval { JSON->new->allow_nonref (1)->decode ('-e+1') }; ok $@ =~ /initial minus/; eval { JSON->new->allow_nonref->decode ("\"\n\"") }; ok $@ =~ /invalid character/; eval { JSON->new->allow_nonref (1)->decode ("\"\x01\"") }; ok $@ =~ /invalid character/; eval { JSON->new->decode ('[5') }; ok $@ =~ /parsing array/; eval { JSON->new->decode ('{"5"') }; ok $@ =~ /':' expected/; eval { JSON->new->decode ('{"5":null') }; ok $@ =~ /parsing object/; eval { JSON->new->decode (undef) }; ok $@ =~ /malformed/; eval { JSON->new->decode (\5) }; ok !!$@; # Can't coerce readonly eval { JSON->new->decode ([]) }; ok $@ =~ /malformed/; eval { JSON->new->decode (\STDERR) }; ok $@ =~ /malformed/; eval { JSON->new->decode (STDERR) }; ok !!$@; # cannot coerce GLOB # differences between JSON::XS and JSON::PP eval { decode_json ("\"\xa0") }; ok $@ =~ /malformed.character/; eval { decode_json ("\"\xa0\"") }; ok $@ =~ /malformed.character/; #eval { decode_json ("\"\xa0") }; ok $@ =~ /JSON text must be an object or array/; #eval { decode_json ("\"\xa0\"") }; ok $@ =~ /JSON text must be an object or array/; } ��21_evans.t��0000644��00000000772�15125143236�0006357 0��ustar�00��# copied over from JSON::XS and modified to use JSON # adapted from a test by Martin Evans use strict; use warnings; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; print "1..1\n"; my $data = ["\x{53f0}\x{6240}\x{306e}\x{6d41}\x{3057}", "\x{6c60}\x{306e}\x{30ab}\x{30a8}\x{30eb}"]; my $js = JSON->new->encode ($data); my $j = JSON->new; my $object = $j->incr_parse ($js); die "no object" if !$object; eval { $j->incr_text }; print $@ ? "not " : "", "ok 1 # $@\n"; ��09_pc_extra_number.t��0000644��00000001402�15125143236�0010415 0��ustar�00��# copied over from JSON::PC and modified to use JSON # copied over from JSON::XS and modified to use JSON use Test::More; use strict; use warnings; BEGIN { plan tests => 6 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; use utf8; ######################### my ($js,$obj); my $pc = JSON->new; $js = '{"foo":0}'; $obj = $pc->decode($js); is($obj->{foo}, 0, "normal 0"); $js = '{"foo":0.1}'; $obj = $pc->decode($js); is($obj->{foo}, 0.1, "normal 0.1"); $js = '{"foo":10}'; $obj = $pc->decode($js); is($obj->{foo}, 10, "normal 10"); $js = '{"foo":-10}'; $obj = $pc->decode($js); is($obj->{foo}, -10, "normal -10"); $js = '{"foo":0, "bar":0.1}'; $obj = $pc->decode($js); is($obj->{foo},0, "normal 0"); is($obj->{bar},0.1,"normal 0.1"); ��e11_conv_blessed_univ.t��0000644��00000001550�15125143236�0011111 0��ustar�00�� use strict; use Test::More; BEGIN { plan tests => 7 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON -convert_blessed_universally; ok( !MyTest->can('TO_JSON') ); ok( MyTest2->can('TO_JSON') ); my $obj = MyTest->new( [ 1, 2, {foo => 'bar'} ] ); $obj->[3] = MyTest2->new( { a => 'b' } ); my $json = JSON->new->allow_blessed->convert_blessed; is( $json->encode( $obj ), '[1,2,{"foo":"bar"},"hoge"]' ); $json->convert_blessed(0); is( $json->encode( $obj ), 'null' ); $json->allow_blessed(0)->convert_blessed(1); is( $json->encode( $obj ), '[1,2,{"foo":"bar"},"hoge"]' ); SKIP: { skip "only works with 5.18+", 1 if $] < 5.018; ok( !MyTest->can('TO_JSON') ); } ok( MyTest2->can('TO_JSON') ); package MyTest; sub new { bless $_[1], $_[0]; } package MyTest2; sub new { bless $_[1], $_[0]; } sub TO_JSON { "hoge"; } ��x12_blessed.t��0000644��00000002604�15125143236�0007050 0��ustar�00��use strict; use Test::More; BEGIN { plan tests => 16 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= 1; } use JSON; SKIP: { skip "can't use JSON::XS.", 16, unless( JSON->backend->is_xs ); my $o1 = bless { a => 3 }, "XX"; my $o2 = bless \(my $dummy = 1), "YY"; sub XX::TO_JSON { {'__',""} } my $js = JSON->new; eval { $js->encode ($o1) }; ok ($@ =~ /allow_blessed/); eval { $js->encode ($o2) }; ok ($@ =~ /allow_blessed/); $js->allow_blessed; ok ($js->encode ($o1) eq "null"); ok ($js->encode ($o2) eq "null"); $js->convert_blessed; ok ($js->encode ($o1) eq '{"__":""}'); ok ($js->encode ($o2) eq "null"); $js->filter_json_object (sub { 5 }); $js->filter_json_single_key_object (a => sub { shift }); $js->filter_json_single_key_object (b => sub { 7 }); ok ("ARRAY" eq ref $js->decode ("[]")); ok (5 eq join ":", @{ $js->decode ('[{}]') }); ok (6 eq join ":", @{ $js->decode ('[{"a":6}]') }); ok (5 eq join ":", @{ $js->decode ('[{"a":4,"b":7}]') }); $js->filter_json_object; ok (7 == $js->decode ('[{"a":4,"b":7}]')->[0]{b}); ok (3 eq join ":", @{ $js->decode ('[{"a":3}]') }); $js->filter_json_object (sub { }); ok (7 == $js->decode ('[{"a":4,"b":7}]')->[0]{b}); ok (9 eq join ":", @{ $js->decode ('[{"a":9}]') }); $js->filter_json_single_key_object ("a"); ok (4 == $js->decode ('[{"a":4}]')->[0]{a}); $js->filter_json_single_key_object (a => sub {}); ok (4 == $js->decode ('[{"a":4}]')->[0]{a}); } ��xe04_escape_slash.t��0000644��00000000647�15125143236�0010234 0��ustar�00��use strict; use Test::More; BEGIN { plan tests => 3 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= 1; } use JSON -support_by_pp; SKIP: { skip "can't use JSON::XS.", 3, unless( JSON->backend->is_xs ); my $json = new JSON; is($json->escape_slash(0)->allow_nonref->encode("/"), '"/"'); is($json->escape_slash(1)->allow_nonref->encode("/"), '"\/"'); is($json->escape_slash(0)->allow_nonref->encode("/"), '"/"'); } __END__ ��xe20_croak_message.t��0000644��00000001111�15125143236�0010366 0��ustar�00��# https://rt.cpan.org/Public/Bug/Display.html?id=61708 use strict; use Test::More; BEGIN { plan tests => 1 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= 1; } use JSON -support_by_pp; #use JSON; # currently it can't pass with -support_by_pp; SKIP: { skip "can't use JSON::XS.", 1, unless( JSON->backend->is_xs ); my $json = JSON->new; my $res = eval q{ $json->encode( undef ) }; my $error = $@; # JSON::XS/JSON::PP 4.0 allow nonref by default if ($json->get_allow_nonref) { is $res => 'null'; } else { like( $error, qr/line 1\./ ); } } ��10_pc_keysort.t��0000644��00000000741�15125143236�0007417 0��ustar�00��# copied over from JSON::PC and modified to use JSON # copied over from JSON::XS and modified to use JSON use Test::More; use strict; use warnings; BEGIN { plan tests => 1 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; ######################### my ($js,$obj); my $pc = JSON->new->canonical(1); $obj = {a=>1, b=>2, c=>3, d=>4, e=>5, f=>6, g=>7, h=>8, i=>9}; $js = $pc->encode($obj); is($js, q\|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}\|); ��xe05_indent_length.t��0000644��00000002344�15125143236�0010421 0��ustar�00��use strict; use Test::More; BEGIN { plan tests => 7 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= 1; } use JSON -support_by_pp; SKIP: { skip "can't use JSON::XS.", 7, unless( JSON->backend->is_xs ); my $json = new JSON; is($json->indent_length(2)->encode([1,{foo => 'bar'}, "1", "/"]), qq\|[1,{"foo":"bar"},"1","/"]\|); is($json->indent->encode([1,{foo => 'bar'}, "1", "/"]), qq\|[ 1, { "foo":"bar" }, "1", "/" ] \|); is($json->escape_slash(1)->pretty->indent_length(2)->encode([1,{foo => 'bar'}, "1", "/"]), qq\|[ 1, { "foo" : "bar" }, "1", "\\/" ] \|); is($json->escape_slash(1)->pretty->indent_length(3)->encode([1,{foo => 'bar'}, "1", "/"]), qq\|[ 1, { "foo" : "bar" }, "1", "\\/" ] \|); is($json->escape_slash(1)->pretty->indent_length(15)->encode([1,{foo => 'bar'}, "1", "/"]), qq\|[ 1, { "foo" : "bar" }, "1", "\\/" ] \|); is($json->indent_length(0)->encode([1,{foo => 'bar'}, "1", "/"]), qq\|[ 1, { "foo" : "bar" }, "1", "\\/" ] \|); is($json->indent(0)->space_before(0)->space_after(0)->escape_slash(0) ->encode([1,{foo => 'bar'}, "1", "/"]), qq\|[1,{"foo":"bar"},"1","/"]\|); } ��02_error.t��0000644��00000005641�15125143236�0006373 0��ustar�00��# copied over from JSON::XS and modified to use JSON use strict; use warnings; use Test::More; BEGIN { plan tests => 35 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use utf8; use JSON; no warnings; eval { JSON->new->encode ([\-1]) }; ok $@ =~ /cannot encode reference/; eval { JSON->new->encode ([\undef]) }; ok $@ =~ /cannot encode reference/; eval { JSON->new->encode ([\2]) }; ok $@ =~ /cannot encode reference/; eval { JSON->new->encode ([\{}]) }; ok $@ =~ /cannot encode reference/; eval { JSON->new->encode ([\[]]) }; ok $@ =~ /cannot encode reference/; eval { JSON->new->encode ([\\1]) }; ok $@ =~ /cannot encode reference/; eval { JSON->new->allow_nonref (1)->decode ('"\u1234\udc00"') }; ok $@ =~ /missing high /; eval { JSON->new->allow_nonref->decode ('"\ud800"') }; ok $@ =~ /missing low /; eval { JSON->new->allow_nonref (1)->decode ('"\ud800\u1234"') }; ok $@ =~ /surrogate pair /; eval { JSON->new->allow_nonref (0)->decode ('null') }; ok $@ =~ /allow_nonref/; eval { JSON->new->allow_nonref (1)->decode ('+0') }; ok $@ =~ /malformed/; eval { JSON->new->allow_nonref->decode ('.2') }; ok $@ =~ /malformed/; eval { JSON->new->allow_nonref (1)->decode ('bare') }; ok $@ =~ /malformed/; eval { JSON->new->allow_nonref->decode ('naughty') }; ok $@ =~ /null/; eval { JSON->new->allow_nonref (1)->decode ('01') }; ok $@ =~ /leading zero/; eval { JSON->new->allow_nonref->decode ('00') }; ok $@ =~ /leading zero/; eval { JSON->new->allow_nonref (1)->decode ('-0.') }; ok $@ =~ /decimal point/; eval { JSON->new->allow_nonref->decode ('-0e') }; ok $@ =~ /exp sign/; eval { JSON->new->allow_nonref (1)->decode ('-e+1') }; ok $@ =~ /initial minus/; eval { JSON->new->allow_nonref->decode ("\"\n\"") }; ok $@ =~ /invalid character/; eval { JSON->new->allow_nonref (1)->decode ("\"\x01\"") }; ok $@ =~ /invalid character/; eval { JSON->new->decode ('[5') }; ok $@ =~ /parsing array/; eval { JSON->new->decode ('{"5"') }; ok $@ =~ /':' expected/; eval { JSON->new->decode ('{"5":null') }; ok $@ =~ /parsing object/; eval { JSON->new->decode (undef) }; ok $@ =~ /malformed/; eval { JSON->new->decode (\5) }; ok !!$@; # Can't coerce readonly eval { JSON->new->decode ([]) }; ok $@ =~ /malformed/; eval { JSON->new->decode (\STDERR) }; ok $@ =~ /malformed/; eval { JSON->new->decode (STDERR) }; ok !!$@; # cannot coerce GLOB eval { decode_json ("\"\xa0") }; ok $@ =~ /malformed.character/; eval { decode_json ("\"\xa0\"") }; ok $@ =~ /malformed.character/; SKIP: { skip "requires JSON::XS 4 compat backend", 4 if ($JSON::BackendModulePP and eval $JSON::BackendModulePP->VERSION < 3) or ($JSON::BackendModule eq 'Cpanel::JSON::XS') or ($JSON::BackendModule eq 'JSON::XS' and $JSON::BackendModule->VERSION < 4); eval { decode_json ("1\x01") }; ok $@ =~ /garbage after/; eval { decode_json ("1\x00") }; ok $@ =~ /garbage after/; eval { decode_json ("\"\"\x00") }; ok $@ =~ /garbage after/; eval { decode_json ("[]\x00") }; ok $@ =~ /garbage after/; } ��x00_load.t��0000644��00000000455�15125143236�0006345 0��ustar�00�� use strict; use Test::More; BEGIN { plan tests => 1 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= 1; } use JSON; SKIP: { skip "can't use JSON::XS.", 1, unless( JSON->backend->is_xs ); diag("load JSON::XS v." . JSON->backend->VERSION ); ok(1, "load JSON::XS v." . JSON->backend->VERSION ); } ��00_backend_version.t��0000644��00000000261�15125143236�0010365 0��ustar�00��use Test::More tests => 1; use strict; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; diag ($JSON::BackendModule.' '.$JSON::BackendModule->VERSION); ok 1; ��15_prefix.t��0000644��00000000627�15125143236�0006542 0��ustar�00��# copied over from JSON::XS and modified to use JSON use strict; use warnings; use Test::More; BEGIN { plan tests => 4 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my $pp = JSON->new->latin1->allow_nonref; eval { $pp->decode ("[] ") }; ok (!$@); eval { $pp->decode ("[] x") }; ok ($@); ok (2 == ($pp->decode_prefix ("[][]"))[1]); ok (3 == ($pp->decode_prefix ("[1] t"))[1]); ��e03_bool2.t��0000644��00000002207�15125143236�0006420 0��ustar�00��use Test::More; BEGIN { plan tests => 16 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; is(to_json([JSON::true]), q\|[true]\|); is(to_json([JSON::false]), q\|[false]\|); is(to_json([JSON::null]), q\|[null]\|); my $jsontext = q\|[true,false,null]\|; my $obj = from_json($jsontext); #push @JSON::backportPP::Boolean::ISA, 'JSON::Boolean'; isa_ok($obj->[0], 'JSON::PP::Boolean'); isa_ok($obj->[1], 'JSON::PP::Boolean'); ok(!defined $obj->[2], 'null is undef'); ok($obj->[0] == 1); ok($obj->[0] != 0); ok($obj->[1] == 0); ok($obj->[1] != 1); # discard overload hack for JSON::XS 3.0 boolean class #ok($obj->[0] eq 'true', 'eq true'); #ok($obj->[0] ne 'false', 'ne false'); #ok($obj->[1] eq 'false', 'eq false'); #ok($obj->[1] ne 'true', 'ne true'); ok($obj->[0] eq $obj->[0]); ok($obj->[0] ne $obj->[1]); #ok(JSON::true eq 'true'); #ok(JSON::true ne 'false'); #ok(JSON::true ne 'null'); #ok(JSON::false eq 'false'); #ok(JSON::false ne 'true'); #ok(JSON::false ne 'null'); ok(!defined JSON::null); is(from_json('[true]' )->[0], JSON::true); is(from_json('[false]')->[0], JSON::false); is(from_json('[null]' )->[0], JSON::null); ��110_bignum.t��0000644��00000002720�15125143236�0006576 0��ustar�00�� use strict; use warnings; use Test::More; BEGIN { plan tests => 9 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON -support_by_pp; eval q\| require Math::BigInt \|; SKIP: { skip "Can't load Math::BigInt.", 9 if ($@); my $v = Math::BigInt->VERSION; $v =~ s/_.+$// if $v; my $fix = !$v ? '+' : $v < 1.6 ? '+' : ''; my $json = JSON->new; $json->allow_nonref->allow_bignum(1); $json->convert_blessed->allow_blessed; my $num = $json->decode(q\|100000000000000000000000000000000000000\|); ok($num->isa('Math::BigInt')); is("$num", $fix . '100000000000000000000000000000000000000'); is($json->encode($num), $fix . '100000000000000000000000000000000000000'); SKIP: { skip "requires $JSON::BackendModule 2.91_03 or newer", 2 if $JSON::BackendModulePP and eval $JSON::BackendModulePP->VERSION < 2.91_03; $num = $json->decode(q\|10\|); ok(!(ref $num and $num->isa('Math::BigInt')), 'small integer is not a BigInt'); ok(!(ref $num and $num->isa('Math::BigFloat')), 'small integer is not a BigFloat'); } $num = $json->decode(q\|2.0000000000000000001\|); ok($num->isa('Math::BigFloat')); is("$num", '2.0000000000000000001'); is($json->encode($num), '2.0000000000000000001'); SKIP: { skip "requires $JSON::BackendModule 2.90 or newer", 1 if $JSON::BackendModulePP and eval $JSON::BackendModulePP->VERSION < 2.90; is($json->encode([Math::BigInt->new("0")]), "[${fix}0]", "zero bigint is 0 (the number), not '0' (the string)" ); } } ��106_allow_barekey.t��0000644��00000000622�15125143236�0010141 0��ustar�00�� use Test::More; use strict; use warnings; BEGIN { plan tests => 2 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON -support_by_pp; ######################### my $json = JSON->new->allow_nonref; eval q\| $json->decode('{foo:"bar"}') \|; ok($@); # in XS and PP, the error message differs. $json->allow_barekey; is($json->decode('{foo:"bar"}')->{foo}, 'bar'); ��120_incr_parse_truncated.t��0000644��00000021316�15125143236�0011516 0��ustar�00��use strict; use warnings; use Test::More; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; plan skip_all => "not for older version of JSON::PP" if JSON->backend->isa('JSON::PP') && JSON->backend->VERSION < 4.09; plan tests => 19 * 3 + 1 * 6; sub run_test { my ($input, $sub) = @_; $sub->($input); } run_test('{"one": 1}', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok ($res, "curly braces okay -- '$input'"); ok (!$e, "no error -- '$input'"); unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error"); }); run_test('{"one": 1]', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "unbalanced curly braces -- '$input'"); ok ($e, "got error -- '$input'"); like ($e, qr/, or \} expected while parsing object\/hash/, "'} expected' json string error"); }); run_test('"', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok (!$e, "no error for input='$input'"); unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); }); run_test('{', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok (!$e, "no error for input='$input'"); unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); }); run_test('[', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok (!$e, "no error for input='$input'"); unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); }); run_test('}', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok ($e, "no error for input='$input'"); like ($e, qr/malformed JSON string/, "'malformed JSON string' json string error for input='$input'"); }); run_test(']', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok ($e, "no error for input='$input'"); like ($e, qr/malformed JSON string/, "'malformed JSON string' json string error for input='$input'"); }); run_test('1', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok ($res, "truncated input='$input'"); ok (!$e, "no error for input='$input'"); unlike ($e, qr/malformed JSON string/, "'malformed JSON string' json string error for input='$input'"); }); run_test('1', sub { my $input = shift; my $coder = JSON->new->allow_nonref(0); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok ($e, "no error for input='$input'"); like ($e, qr/JSON text must be an object or array/, "'JSON text must be an object or array' json string error for input='$input'"); }); run_test('"1', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok (!$e, "no error for input='$input'"); unlike ($e, qr/malformed JSON string/, "'malformed JSON string' json string error for input='$input'"); }); run_test('\\', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok ($e, "no error for input='$input'"); like ($e, qr/malformed JSON string/, "'malformed JSON string' json string error for input='$input'"); }); run_test('{"one": "', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok (!$e, "no error for input='$input'"); unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); }); run_test('{"one": {', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok (!$e, "no error for input='$input'"); unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); }); run_test('{"one": [', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok (!$e, "no error for input='$input'"); unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); }); run_test('{"one": t', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok (!$e, "no error for input='$input'"); unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); }); run_test('{"one": \\', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok (!$e, "no error for input='$input'"); unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); }); run_test('{"one": ', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok (!$e, "no error for input='$input'"); unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); }); run_test('{"one": 1', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok (!$e, "no error for input='$input'"); unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); }); run_test('{"one": {"two": 2', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated '$input'"); ok (!$e, "no error -- '$input'"); unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error -- $input"); }); # Test Appending Closing '}' Curly Bracket run_test('{"one": 1', sub { my $input = shift; my $coder = JSON->new->allow_nonref(1); my $res = eval { $coder->incr_parse($input) }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "truncated input='$input'"); ok (!$e, "no error for input='$input'"); unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); $res = eval { $coder->incr_parse('}') }; $e = $@; # test more clobbers $@, we need it twice ok ($res, "truncated input='$input' . '}'"); ok (!$e, "no error for input='$input' . '}'"); unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input' . '}'"); }); ��e01_property.t��0000644��00000003177�15125143236�0007274 0��ustar�00�� use Test::More; use strict; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my @simples = qw/ascii latin1 utf8 indent canonical space_before space_after allow_nonref shrink allow_blessed convert_blessed relaxed /; my $json = new JSON; # JSON::XS/JSON::PP 4.0 allow nonref by default my $allow_nonref_by_default = $json->allow_nonref; my $has_allow_tags = 0; if ($json->can('allow_tags') and !ref $json->allow_tags) { push @simples, 'allow_tags'; $has_allow_tags = 1; } plan tests => 90 + $has_allow_tags * 7; for my $name (@simples) { my $method = 'get_' . $name; if ($name eq 'allow_nonref' and $allow_nonref_by_default) { ok( $json->$method(), $method . ' default'); } else { ok(! $json->$method(), $method . ' default'); } $json->$name(); ok($json->$method(), $method . ' set true'); $json->$name(0); ok(! $json->$method(), $method . ' set false'); $json->$name(); ok($json->$method(), $method . ' set true again'); } ok($json->get_max_depth == 512, 'get_max_depth default'); $json->max_depth(7); ok($json->get_max_depth == 7, 'get_max_depth set 7 => 7'); $json->max_depth(); ok($json->get_max_depth != 0, 'get_max_depth no arg'); ok($json->get_max_size == 0, 'get_max_size default'); $json->max_size(7); ok($json->get_max_size == 7, 'get_max_size set 7 => 7'); $json->max_size(); ok($json->get_max_size == 0, 'get_max_size no arg'); for my $name (@simples) { $json->$name(); ok($json->property($name), $name); $json->$name(0); ok(! $json->property($name), $name); $json->$name(); ok($json->property($name), $name); } ��gh_29_trailing_false_value.t��0000644��00000000512�15125143236�0012100 0��ustar�00��use strict; use warnings; use Test::More; BEGIN { plan tests => 1 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; SKIP: { skip "requires $JSON::BackendModule 2.90 or newer", 1 if $JSON::BackendModulePP and eval $JSON::BackendModulePP->VERSION < 2.90; eval { JSON->new->decode('{}0') }; ok $@; } ��105_esc_slash.t��0000644��00000000505�15125143236�0007264 0��ustar�00�� use Test::More; use strict; use warnings; BEGIN { plan tests => 2 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON -support_by_pp; ######################### my $json = JSON->new->allow_nonref; my $js = '/'; is($json->encode($js), '"/"'); is($json->escape_slash->encode($js), '"\/"'); ��117_numbers.t��0000644��00000001522�15125143236�0006776 0��ustar�00��use Test::More; use strict; use warnings; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } BEGIN { $ENV{PERL_JSON_PP_USE_B} = 0 } use JSON; BEGIN { plan skip_all => "requires $JSON::BackendModule 2.90 or newer" if JSON->backend->is_pp and eval $JSON::BackendModule->VERSION < 2.90 } BEGIN { plan skip_all => "not for $JSON::BackendModule" if $JSON::BackendModule eq 'JSON::XS' } BEGIN { plan tests => 3 } # TODO ("inf"/"nan" representations are not portable) # is encode_json([999]), '["inf"]'; # is encode_json([-sin(999)]), '["nan"]'; my $num = 3; my $str = "$num"; is encode_json({test => [$num, $str]}), '{"test":[3,"3"]}'; $num = 3.21; $str = "$num"; is encode_json({test => [$num, $str]}), '{"test":[3.21,"3.21"]}'; $str = '0 but true'; $num = 1 + $str; is encode_json({test => [$num, $str]}), '{"test":[1,"0 but true"]}'; ��12_blessed.t��0000644��00000002671�15125143236�0006664 0��ustar�00��# copied over from JSON::XS and modified to use JSON use strict; use warnings; use Test::More; BEGIN { plan tests => 16 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my $o1 = bless { a => 3 }, "XX"; my $o2 = bless \(my $dummy = 1), "YY"; sub XX::TO_JSON { {'__',""} } my $js = JSON->new; eval { $js->encode ($o1) }; ok ($@ =~ /allow_blessed/); eval { $js->encode ($o2) }; ok ($@ =~ /allow_blessed/); $js->allow_blessed; ok ($js->encode ($o1) eq "null"); ok ($js->encode ($o2) eq "null"); $js->convert_blessed; ok ($js->encode ($o1) eq '{"__":""}'); ok ($js->encode ($o2) eq "null"); $js->filter_json_object (sub { 5 }); $js->filter_json_single_key_object (a => sub { shift }); $js->filter_json_single_key_object (b => sub { 7 }); ok ("ARRAY" eq ref $js->decode ("[]")); ok (5 eq join ":", @{ $js->decode ('[{}]') }); ok (6 eq join ":", @{ $js->decode ('[{"a":6}]') }); ok (5 eq join ":", @{ $js->decode ('[{"a":4,"b":7}]') }); $js->filter_json_object; ok (7 == $js->decode ('[{"a":4,"b":7}]')->[0]{b}); ok (3 eq join ":", @{ $js->decode ('[{"a":3}]') }); $js->filter_json_object (sub { }); ok (7 == $js->decode ('[{"a":4,"b":7}]')->[0]{b}); ok (9 eq join ":", @{ $js->decode ('[{"a":9}]') }); $js->filter_json_single_key_object ("a"); ok (4 == $js->decode ('[{"a":4}]')->[0]{a}); $js->filter_json_single_key_object (a => sub { return; }); # sub {} is not suitable for Perl 5.6 ok (4 == $js->decode ('[{"a":4}]')->[0]{a}); ��17_relaxed.t��0000644��00000001235�15125143236�0006667 0��ustar�00��# copied over from JSON::XS and modified to use JSON use strict; use warnings; use Test::More; BEGIN { plan tests => 8 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use utf8; use JSON; my $json = JSON->new->relaxed; ok ('[1,2,3]' eq encode_json $json->decode (' [1,2, 3]')); ok ('[1,2,4]' eq encode_json $json->decode ('[1,2, 4 , ]')); ok (!eval { $json->decode ('[1,2, 3,4,,]') }); ok (!eval { $json->decode ('[,1]') }); ok ('{"1":2}' eq encode_json $json->decode (' {"1":2}')); ok ('{"1":2}' eq encode_json $json->decode ('{"1":2,}')); ok (!eval { $json->decode ('{,}') }); ok ('[1,2]' eq encode_json $json->decode ("[1#,2\n ,2,# ] \n\t]")); ��14_latin1.t��0000644��00000001010�15125143236�0006417 0��ustar�00��# copied over from JSON::XS and modified to use JSON use strict; use warnings; use Test::More; BEGIN { plan tests => 4 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my $pp = JSON->new->latin1->allow_nonref; ok ($pp->encode ("\x{12}\x{b6} ") eq "\"\\u0012\x{b6} \""); ok ($pp->encode ("\x{12}\x{b6}\x{abc}") eq "\"\\u0012\x{b6}\\u0abc\""); ok ($pp->decode ("\"\\u0012\x{b6}\"" ) eq "\x{12}\x{b6}"); ok ($pp->decode ("\"\\u0012\x{b6}\\u0abc\"") eq "\x{12}\x{b6}\x{abc}"); ��19_incr.t��0000644��00000006505�15125143236�0006205 0��ustar�00��# copied over from JSON::XS and modified to use JSON use strict; no warnings; use Test::More; BEGIN { plan tests => 745 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; sub splitter { my ($coder, $text) = @_; # work around hash randomisation bug introduced in 5.18 $coder->canonical; for (0 .. length $text) { my $a = substr $text, 0, $_; my $b = substr $text, $_; $coder->incr_parse ($a); $coder->incr_parse ($b); my $data = $coder->incr_parse; #ok (defined $data, "split<$a><$b>"); ok (defined $data, "split"); my $e1 = $coder->encode ($data); my $e2 = $coder->encode ($coder->decode ($text)); #ok ($e1 eq $e2, "data<$a><$b><$e1><$e2>"); #ok ($coder->incr_text =~ /^\s$/, "tailws<$a><$b>"); ok ($e1 eq $e2, "data"); ok ($coder->incr_text =~ /^\s$/, "tailws"); } } splitter +JSON->new->allow_nonref (0), ' ["x\\"","\\u1000\\\\n\\nx",1,{"\\\\" :5 , "": "x"}]'; splitter +JSON->new->allow_nonref (0), '[ "x\\"","\\u1000\\\\n\\nx" , 1,{"\\\\ " :5 , "": " x"} ] '; splitter +JSON->new->allow_nonref (1), '"test"'; splitter +JSON->new->allow_nonref (1), ' "5" '; splitter +JSON->new->allow_nonref (1), '-1e5'; SKIP: { skip "requires $JSON::BackendModule 3 or newer", 33 if $JSON::BackendModulePP and eval $JSON::BackendModulePP->VERSION < 3; splitter +JSON->new->allow_nonref (1), ' 0.00E+00 '; } { my $text = '[5],{"":1} , [ 1,2, 3], {"3":null}'; my $coder = JSON->new; for (0 .. length $text) { my $a = substr $text, 0, $_; my $b = substr $text, $_; $coder->incr_parse ($a); $coder->incr_parse ($b); my $j1 = $coder->incr_parse; ok ($coder->incr_text =~ s/^\s,//, "cskip1"); my $j2 = $coder->incr_parse; ok ($coder->incr_text =~ s/^\s,//, "cskip2"); my $j3 = $coder->incr_parse; ok ($coder->incr_text =~ s/^\s,//, "cskip3"); my $j4 = $coder->incr_parse; ok ($coder->incr_text !~ s/^\s,//, "cskip4"); my $j5 = $coder->incr_parse; ok ($coder->incr_text !~ s/^\s,//, "cskip5"); ok ('[5]' eq encode_json($j1), "cjson1"); ok ('{"":1}' eq encode_json($j2), "cjson2"); ok ('[1,2,3]' eq encode_json($j3), "cjson3"); ok ('{"3":null}' eq encode_json($j4), "cjson4"); ok (!defined $j5, "cjson5"); } } { my $text = '[x][5]'; my $coder = JSON->new; $coder->incr_parse ($text); ok (!eval { $coder->incr_parse }, "sparse1"); ok (!eval { $coder->incr_parse }, "sparse2"); $coder->incr_skip; ok ('[5]' eq $coder->encode (scalar $coder->incr_parse), "sparse3"); } { my $coder = JSON->new->max_size (5); ok (!$coder->incr_parse ("[ "), "incsize1"); eval { !$coder->incr_parse ("] ") }; ok ($@ =~ /6 bytes/, "incsize2 $@"); } { my $coder = JSON->new->max_depth (3); ok (!$coder->incr_parse ("[[["), "incdepth1"); eval { !$coder->incr_parse (" [] ") }; ok ($@ =~ /maximum nesting/, "incdepth2 $@"); } # contributed by yuval kogman, reformatted to fit style { my $coder = JSON->new; my $res = eval { $coder->incr_parse("]") }; my $e = $@; # test more clobbers $@, we need it twice ok (!$res, "unbalanced bracket"); ok ($e, "got error"); like ($e, qr/malformed/, "malformed json string error"); $coder->incr_skip; is_deeply (eval { $coder->incr_parse("[42]") }, [42], "valid data after incr_skip"); } ��rt_90071_incr_parse.t��0000644��00000001460�15125143236�0010326 0��ustar�00��use strict; use warnings; use Test::More; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; BEGIN { plan skip_all => "requires $JSON::BackendModule 2.90 or newer" if JSON->backend->is_pp and eval $JSON::BackendModule->VERSION < 2.90 } BEGIN { plan tests => 2 }; my $json = JSON->new; my $kb = 'a' x 1024; my $hash = { map { $_ => $kb } (1..40) }; my $data = join ( '', $json->encode($hash), $json->encode($hash) ); my $size = length($data); # note "Total size: [$size]"; my $offset = 0; while ($size) { # note "Bytes left [$size]"; my $incr = substr($data, $offset, 4096); my $bytes = length($incr); $size -= $bytes; $offset += $bytes; if ($bytes) { $json->incr_parse($incr); } while( my $obj = $json->incr_parse ) { ok "Got JSON object"; } } ��11_pc_expo.t��0000644��00000003170�15125143236�0006672 0��ustar�00��# copied over from JSON::PC and modified to use JSON # copied over from JSON::XS and modified to use JSON use Test::More; use strict; use warnings; BEGIN { plan tests => 8 + 2 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; ######################### my ($js,$obj); my $pc = JSON->new; $js = q\|[-12.34]\|; $obj = $pc->decode($js); is($obj->[0], -12.34, 'digit -12.34'); $js = $pc->encode($obj); is($js,'[-12.34]', 'digit -12.34'); $js = q\|[-1.234e5]\|; $obj = $pc->decode($js); is($obj->[0], -123400, 'digit -1.234e5'); SKIP: { skip "not for $JSON::BackendModule", 1 if $JSON::BackendModule eq 'Cpanel::JSON::XS'; $js = $pc->encode($obj); is($js,'[-123400]', 'digit -1.234e5'); } $js = q\|[1.23E-4]\|; $obj = $pc->decode($js); is($obj->[0], 0.000123, 'digit 1.23E-4'); $js = $pc->encode($obj); is($js,'[0.000123]', 'digit 1.23E-4'); $js = q\|[1.01e+30]\|; $obj = $pc->decode($js); is($obj->[0], 1.01e+30, 'digit 1.01e+30'); $js = $pc->encode($obj); like($js,qr/\[(?:1.01[Ee]\+0?30\|1010000000000000000000000000000)]/, 'digit 1.01e+30'); # RT-128589 (-Duselongdouble or -Dquadmath) my $vax_float = (pack("d",1) =~ /^[\x80\x10]\x40/); if ($vax_float) { # VAX has smaller float range. $js = q\|[1.01e+37]\|; $obj = $pc->decode($js); is($obj->[0], eval '1.01e+37', 'digit 1.01e+37'); $js = $pc->encode($obj); like($js,qr/\[1.01[Ee]\+0?37\]/, 'digit 1.01e+37'); } else { $js = q\|[1.01e+67]\|; # 30 -> 67 ... patched by H.Merijn Brand $obj = $pc->decode($js); is($obj->[0], eval '1.01e+67', 'digit 1.01e+67'); $js = $pc->encode($obj); like($js,qr/\[1.01[Ee]\+0?67\]/, 'digit 1.01e+67'); } ��104_sortby.t��0000644��00000001270�15125143236�0006641 0��ustar�00�� use Test::More; use strict; use warnings; BEGIN { plan tests => 3 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON -support_by_pp; ######################### my ($js,$obj); my $pc = JSON->new; $obj = {a=>1, b=>2, c=>3, d=>4, e=>5, f=>6, g=>7, h=>8, i=>9}; $js = $pc->sort_by(1)->encode($obj); is($js, q\|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}\|); $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj); is($js, q\|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}\|); $js = $pc->sort_by('hoge')->encode($obj); is($js, q\|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}\|); sub JSON::PP::hoge { $JSON::PP::a cmp $JSON::PP::b } ��00_load.t��0000644��00000000412�15125143236�0006146 0��ustar�00��# copied over from JSON::XS and modified to use JSON use strict; use warnings; my $loaded; BEGIN { $\| = 1; print "1..1\n"; } END {print "not ok 1\n" unless $loaded;} BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; $loaded = 1; print "ok 1\n"; ��113_overloaded_eq.t��0000644��00000001776�15125143236�0010143 0��ustar�00��use strict; use warnings; use Test::More tests => 4; BEGIN { $ENV{ PERL_JSON_BACKEND } = 0; } BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my $json = JSON->new->convert_blessed; my $obj = OverloadedObject->new( 'foo' ); ok( $obj eq 'foo' ); is( $json->encode( [ $obj ] ), q{["foo"]} ); # rt.cpan.org #64783 my $foo = bless {}, 'Foo'; my $bar = bless {}, 'Bar'; eval q{ $json->encode( $foo ) }; ok($@); eval q{ $json->encode( $bar ) }; ok(!$@); package Foo; use strict; use warnings; use overload ( 'eq' => sub { 0 }, '""' => sub { $_[0] }, fallback => 1, ); sub TO_JSON { return $_[0]; } package Bar; use strict; use warnings; use overload ( 'eq' => sub { 0 }, '""' => sub { $_[0] }, fallback => 1, ); sub TO_JSON { return overload::StrVal($_[0]); } package OverloadedObject; use overload 'eq' => sub { $_[0]->{v} eq $_[1] }, '""' => sub { $_[0]->{v} }, fallback => 1; sub new { bless { v => $_[1] }, $_[0]; } sub TO_JSON { "$_[0]"; } ��115_tie_ixhash.t��0000644��00000001362�15125143236�0007450 0��ustar�00�� use strict; use warnings; use Test::More; BEGIN { plan tests => 2 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; # from https://rt.cpan.org/Ticket/Display.html?id=25162 SKIP: { eval {require Tie::IxHash}; skip "Can't load Tie::IxHash.", 2 if ($@); my %columns; tie %columns, 'Tie::IxHash'; %columns = ( id => 'int', 1 => 'a', 2 => 'b', 3 => 'c', 4 => 'd', 5 => 'e', ); my $json = JSON->new; my $js = $json->encode(\%columns); is( $js, q/{"id":"int","1":"a","2":"b","3":"c","4":"d","5":"e"}/ ); $js = $json->pretty->encode(\%columns); is( $js, <<'STR' ); { "id" : "int", "1" : "a", "2" : "b", "3" : "c", "4" : "d", "5" : "e" } STR } ��e02_bool.t��0000644��00000002362�15125143236�0006337 0��ustar�00��use strict; use Test::More; use strict; BEGIN { plan tests => 8 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my $json = new JSON; diag $json->backend->isa('JSON::PP'); my $not_not_a_number_is_a_number = ( $json->backend->isa('Cpanel::JSON::XS') \|\| ($json->backend->isa('JSON::PP') && ($JSON::PP::Boolean::VERSION \|\| $JSON::backportPP::Boolean::VERSION)) ) ? 1 : 0; my $core_bool_support = JSON->backend->can("CORE_BOOL") && JSON->backend->CORE_BOOL ? 1 : 0; is($json->encode([!1]), $core_bool_support ? '[false]' : '[""]'); if ($not_not_a_number_is_a_number) { is($json->encode([!!2]), $core_bool_support ? '[true]' : '[1]'); } else { is($json->encode([!!2]), '["1"]'); } is($json->encode([ 'a' eq 'b' ]), $core_bool_support ? '[false]' : '[""]'); if ($not_not_a_number_is_a_number) { is($json->encode([ 'a' eq 'a' ]), $core_bool_support ? '[true]' : '[1]'); } else { is($json->encode([ 'a' eq 'a' ]), '["1"]'); } is($json->encode([ ('a' eq 'b') + 1 ]), '[1]'); is($json->encode([ ('a' eq 'a') + 1 ]), '[2]'); # discard overload hack for JSON::XS 3.0 boolean class #ok(JSON::true eq 'true'); #ok(JSON::true eq '1'); ok(JSON::true == 1); isa_ok(JSON::true, 'JSON::PP::Boolean'); #isa_ok(JSON::true, 'JSON::Boolean'); ��zero-mojibake.t��0000644��00000000605�15125143236�0007472 0��ustar�00��use strict; use warnings; use Test::More; BEGIN { plan tests => 1 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my $json = JSON->new; my $input = q[ { "dynamic_config" : 0, "x_contributors" : [ "å¤§æ²¢ åå®", "Ãvar ArnfjÃ¶rÃ°" ] } ]; eval { $json->decode($input) }; is $@, '', 'decodes 0 with mojibake without error'; ��99_binary.t��0000644��00000002746�15125143236�0006551 0��ustar�00��# copied over from JSON::XS and modified to use JSON use strict; use warnings; use Test::More; BEGIN { plan tests => 24576 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; sub test($) { my $js; $js = JSON->new->allow_nonref(0)->utf8->ascii->shrink->encode ([$_[0]]); ok ($_[0] eq ((decode_json $js)->[0]), " - 0"); $js = JSON->new->allow_nonref(0)->utf8->ascii->encode ([$_[0]]); ok ($_[0] eq (JSON->new->utf8->shrink->decode($js))->[0], " - 1"); $js = JSON->new->allow_nonref(0)->utf8->shrink->encode ([$_[0]]); ok ($_[0] eq ((decode_json $js)->[0]), " - 2"); $js = JSON->new->allow_nonref(1)->utf8->encode ([$_[0]]); ok ($_[0] eq (JSON->new->utf8->shrink->decode($js))->[0], " - 3"); $js = JSON->new->allow_nonref(1)->ascii->encode ([$_[0]]); ok ($_[0] eq JSON->new->decode ($js)->[0], " - 4"); $js = JSON->new->allow_nonref(0)->ascii->encode ([$_[0]]); ok ($_[0] eq JSON->new->shrink->decode ($js)->[0], " - 5"); $js = JSON->new->allow_nonref(1)->shrink->encode ([$_[0]]); ok ($_[0] eq JSON->new->decode ($js)->[0], " - 6"); $js = JSON->new->allow_nonref(0)->encode ([$_[0]]); ok ($_[0] eq JSON->new->shrink->decode ($js)->[0], " - 7"); } srand 0; # doesn't help too much, but its at least more deterministic for (1..768) { test join "", map chr ($_ & 255), 0..$_; test join "", map chr rand 255, 0..$_; test join "", map chr ($_ 97 & ~0x4000), 0..$_; test join "", map chr (rand (220) & ~0x800), 0..$_; } ��13_limit.t��0000644��00000001607�15125143236�0006360 0��ustar�00��# copied over from JSON::XS and modified to use JSON use strict; use warnings; use Test::More; BEGIN { plan tests => 11 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my $def = 512; my $js = JSON->new; local $^W; # to silence Deep recursion warnings ok (!eval { $js->decode (("[" x ($def + 1)) . ("]" x ($def + 1))) }); ok (ref $js->decode (("[" x $def) . ("]" x $def))); ok (ref $js->decode (("{\"\":" x ($def - 1)) . "[]" . ("}" x ($def - 1)))); ok (!eval { $js->decode (("{\"\":" x $def) . "[]" . ("}" x $def)) }); ok (ref $js->max_depth (32)->decode (("[" x 32) . ("]" x 32))); ok ($js->max_depth(1)->encode ([])); ok (!eval { $js->encode ([[]]), 1 }); ok ($js->max_depth(2)->encode ([{}])); ok (!eval { $js->encode ([[{}]]), 1 }); ok (eval { ref $js->max_size (8)->decode ("[ ]") }); eval { $js->max_size (8)->decode ("[ ]") }; ok ($@ =~ /max_size/); ��e90_misc.t��0000644��00000000651�15125143236�0006345 0��ustar�00��use strict; use Test::More tests => 4; BEGIN { $ENV{ PERL_JSON_BACKEND } \|\|= 'JSON::backportPP'; } use JSON; # reported by https://rt.cpan.org/Public/Bug/Display.html?id=68359 eval { JSON->to_json( 5, { allow_nonref => 1 } ) }; ok($@); is( q{"5"}, JSON::to_json( "5", { allow_nonref => 1 } ) ); is( q{5}, JSON::to_json( 5, { allow_nonref => 1 } ) ); is( q{"JSON"}, JSON::to_json( 'JSON', { allow_nonref => 1 } ) ); ��04_dwiw_encode.t��0000644��00000004131�15125143236�0007524 0��ustar�00��# copied over from JSON::XS and modified to use JSON # copied over from JSON::DWIW and modified to use JSON # Creation date: 2007-02-20 19:51:06 # Authors: don use strict; use warnings; use Test::More tests => 5; # main { BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my $data; # my $expected_str = '{"var1":"val1","var2":["first_element",{"sub_element":"sub_val","sub_element2":"sub_val2"}],"var3":"val3"}'; my $expected_str1 = '{"var1":"val1","var2":["first_element",{"sub_element":"sub_val","sub_element2":"sub_val2"}]}'; my $expected_str2 = '{"var2":["first_element",{"sub_element":"sub_val","sub_element2":"sub_val2"}],"var1":"val1"}'; my $expected_str3 = '{"var2":["first_element",{"sub_element2":"sub_val2","sub_element":"sub_val"}],"var1":"val1"}'; my $expected_str4 = '{"var1":"val1","var2":["first_element",{"sub_element2":"sub_val2","sub_element":"sub_val"}]}'; my $json_obj = JSON->new->allow_nonref (1); my $json_str; # print STDERR "\n" . $json_str . "\n\n"; my $expected_str; $data = 'stuff'; $json_str = $json_obj->encode($data); ok($json_str eq '"stuff"'); $data = "stu\nff"; $json_str = $json_obj->encode($data); ok($json_str eq '"stu\nff"'); $data = [ 1, 2, 3 ]; $expected_str = '[1,2,3]'; $json_str = $json_obj->encode($data); ok($json_str eq $expected_str); $data = { var1 => 'val1', var2 => 'val2' }; $json_str = $json_obj->encode($data); ok($json_str eq '{"var1":"val1","var2":"val2"}' or $json_str eq '{"var2":"val2","var1":"val1"}'); $data = { var1 => 'val1', var2 => [ 'first_element', { sub_element => 'sub_val', sub_element2 => 'sub_val2' }, ], # var3 => 'val3', }; $json_str = $json_obj->encode($data); ok($json_str eq $expected_str1 or $json_str eq $expected_str2 or $json_str eq $expected_str3 or $json_str eq $expected_str4); } exit 0; ############################################################################### # Subroutines ��108_decode.t��0000644��00000002131�15125143236�0006543 0��ustar�00��# # decode on Perl 5.005, 5.6, 5.8 or later # use strict; use warnings; use Test::More; BEGIN { plan tests => 7 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } my $isASCII = ord "A" == 65; use JSON; no utf8; my $json = JSON->new->allow_nonref; is($json->decode(q\|"ü"\|), "ü"); # utf8 is($json->decode(q\|"\u00fc"\|), "\xfc"); # latin1 is($json->decode(q\|"\u00c3\u00bc"\|), "\xc3\xbc"); # utf8 my $str = 'あ'; # Japanese 'a' in utf8 is($json->decode(($isASCII) ? q\|"\u00e3\u0081\u0082"\| : q\|"\u00ce\u0043\u0043"\|), $str); utf8::decode($str); # usually UTF-8 flagged on, but no-op for 5.005. is($json->decode(q\|"\u3042"\|), $str); # chr 0x12400, which was chosen because it has the same representation in # both EBCDIC 1047 and 037 my $utf8 = $json->decode(q\|"\ud809\udc00"\|); utf8::encode($utf8); # UTF-8 flagged off is($utf8, ($isASCII) ? "\xf0\x92\x90\x80" : "\xDE\x4A\x41\x41"); eval { $json->decode(q\|{"action":"foo" "method":"bar","tid":1}\|) }; my $error = $@; like $error => qr!""method":"bar","tid"..."!; ��xe21_is_pp.t��0000644��00000001105�15125143236�0006701 0��ustar�00��use strict; use Test::More; BEGIN { plan tests => 5 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= 1; } use JSON; my $json = JSON->new(); ok( $json->backend, 'backend is ' . $json->backend ); if ( $json->backend->is_xs ) { ok (!JSON->is_pp(), 'JSON->is_pp()'); ok ( JSON->is_xs(), 'JSON->is_xs()'); ok (!$json->is_pp(), '$json->is_pp()'); ok ( $json->is_xs(), '$json->is_xs()'); } else { ok ( JSON->is_pp(), 'JSON->is_pp()'); ok (!JSON->is_xs(), 'JSON->is_xs()'); ok ( $json->is_pp(), '$json->is_pp()'); ok (!$json->is_xs(), '$json->is_xs()'); } ��rt_116998_wrong_character_offset.t��0000644��00000001316�15125143236�0013020 0��ustar�00��use strict; use warnings; use Test::More; BEGIN { plan tests => 4 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; SKIP: { skip "requires $JSON::BackendModule 2.90 or newer", 1 if $JSON::BackendModulePP and eval $JSON::BackendModulePP->VERSION < 2.90; eval { decode_json(qq({"foo":{"bar":42})) }; like $@ => qr/offset 17/; # 16 } eval { decode_json(qq(["foo",{"bar":42})) }; like $@ => qr/offset 17/; SKIP: { skip "requires $JSON::BackendModule 2.90 or newer", 1 if $JSON::BackendModulePP and eval $JSON::BackendModulePP->VERSION < 2.90; eval { decode_json(qq(["foo",{"bar":42}"])) }; like $@ => qr/offset 17/; # 18 } eval { decode_json(qq({"foo":{"bar":42}"})) }; like $@ => qr/offset 17/; ��52_object.t��0000644��00000002275�15125143236�0006515 0��ustar�00��# copied over from JSON::XS and modified to use JSON package JSON::freeze; 1; package JSON::tojson; 1; package main; use strict; use warnings; use Test::More; BEGIN { $^W = 0 } # hate BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my $backend_version = JSON->backend->VERSION; $backend_version =~ s/_//; plan skip_all => "allow_tags is not supported" if $backend_version < 3; plan tests => 20; my $json = JSON->new->convert_blessed->allow_tags->allow_nonref; ok (1); sub JSON::tojson::TO_JSON { ok (@_ == 1); ok (JSON::tojson:: eq ref $_[0]); ok ($_[0]{k} == 1); 7 } my $obj = bless { k => 1 }, JSON::tojson::; ok (1); my $enc = $json->encode ($obj); ok ($enc eq 7); ok (1); sub JSON::freeze::FREEZE { ok (@_ == 2); ok ($_[1] eq "JSON"); ok (JSON::freeze:: eq ref $_[0]); ok ($_[0]{k} == 1); (3, 1, 2) } sub JSON::freeze::THAW { ok (@_ == 5); ok (JSON::freeze:: eq $_[0]); ok ($_[1] eq "JSON"); ok ($_[2] == 3); ok ($_[3] == 1); ok ($_[4] == 2); 777 } $obj = bless { k => 1 }, JSON::freeze::; $enc = $json->encode ($obj); ok ($enc eq '("JSON::freeze")[3,1,2]'); my $dec = $json->decode ($enc); ok ($dec eq 777); ok (1); ��107_allow_singlequote.t��0000644��00000001016�15125143236�0011055 0��ustar�00�� use Test::More; use strict; use warnings; BEGIN { plan tests => 4 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON -support_by_pp; ######################### my $json = JSON->new->allow_nonref; eval q\| $json->decode("{'foo':'bar'}") \|; ok($@); # in XS and PP, the error message differs. $json->allow_singlequote; is($json->decode(q\|{'foo':"bar"}\|)->{foo}, 'bar'); is($json->decode(q\|{'foo':'bar'}\|)->{foo}, 'bar'); is($json->allow_barekey->decode(q\|{foo:'bar'}\|)->{foo}, 'bar'); ��00_load_backport_pp.t��0000644��00000000511�15125143236�0010532 0��ustar�00��use Test::More; use strict; BEGIN { plan tests => 5 }; BEGIN { $ENV{PERL_JSON_BACKEND} = "JSON::backportPP"; } BEGIN { use_ok('JSON'); } ok( exists $INC{ 'JSON/backportPP.pm' }, 'load backportPP' ); ok( ! exists $INC{ 'JSON/PP.pm' }, q/didn't load PP/ ); ok( JSON->backend->isa('JSON::PP') ); ok( JSON->backend->is_pp ); ��07_pc_esc.t��0000644��00000003744�15125143236�0006505 0��ustar�00��# # このファイルのエンコーディングはUTF-8 # # copied over from JSON::PC and modified to use JSON # copied over from JSON::XS and modified to use JSON use Test::More; use strict; use warnings; use utf8; BEGIN { plan tests => 17 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; ######################### my ($js,$obj,$str); my $pc = JSON->new; $obj = {test => qq\|abc"def\|}; $str = $pc->encode($obj); is($str,q\|{"test":"abc\"def"}\|); $obj = {qq\|te"st\| => qq\|abc"def\|}; $str = $pc->encode($obj); is($str,q\|{"te\"st":"abc\"def"}\|); $obj = {test => qq\|abc/def\|}; # / => \/ $str = $pc->encode($obj); # but since version 0.99 is($str,q\|{"test":"abc/def"}\|); # this handling is deleted. $obj = $pc->decode($str); is($obj->{test},q\|abc/def\|); $obj = {test => q\|abc\def\|}; $str = $pc->encode($obj); is($str,q\|{"test":"abc\\\\def"}\|); $obj = {test => "abc\bdef"}; $str = $pc->encode($obj); is($str,q\|{"test":"abc\bdef"}\|); $obj = {test => "abc\fdef"}; $str = $pc->encode($obj); is($str,q\|{"test":"abc\fdef"}\|); $obj = {test => "abc\ndef"}; $str = $pc->encode($obj); is($str,q\|{"test":"abc\ndef"}\|); $obj = {test => "abc\rdef"}; $str = $pc->encode($obj); is($str,q\|{"test":"abc\rdef"}\|); $obj = {test => "abc-def"}; $str = $pc->encode($obj); is($str,q\|{"test":"abc-def"}\|); $obj = {test => "abc(def"}; $str = $pc->encode($obj); is($str,q\|{"test":"abc(def"}\|); $obj = {test => "abc\\def"}; $str = $pc->encode($obj); is($str,q\|{"test":"abc\\\\def"}\|); $obj = {test => "あいうえお"}; $str = $pc->encode($obj); is($str,q\|{"test":"あいうえお"}\|); $obj = {"あいうえお" => "かきくけこ"}; $str = $pc->encode($obj); is($str,q\|{"あいうえお":"かきくけこ"}\|); $obj = $pc->decode(q\|{"id":"abc\ndef"}\|); is($obj->{id},"abc\ndef",q\|{"id":"abc\ndef"}\|); $obj = $pc->decode(q\|{"id":"abc\\\ndef"}\|); is($obj->{id},"abc\\ndef",q\|{"id":"abc\\\ndef"}\|); $obj = $pc->decode(q\|{"id":"abc\\\\\ndef"}\|); is($obj->{id},"abc\\\ndef",q\|{"id":"abc\\\\\ndef"}\|); ��16_tied.t��0000644��00000000625�15125143236�0006171 0��ustar�00��# copied over from JSON::XS and modified to use JSON use strict; use warnings; use Test::More; BEGIN { plan tests => 2 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; use Tie::Hash; use Tie::Array; my $js = JSON->new; tie my %h, 'Tie::StdHash'; %h = (a => 1); ok ($js->encode (\%h) eq '{"a":1}'); tie my @a, 'Tie::StdArray'; @a = (1, 2); ok ($js->encode (\@a) eq '[1,2]'); ��05_dwiw_decode.t��0000644��00000004137�15125143236�0007521 0��ustar�00��# copied over from JSON::XS and modified to use JSON # copied over from JSON::DWIW and modified to use JSON # Creation date: 2007-02-20 21:54:09 # Authors: don use strict; use warnings; use Test::More tests => 7; # main { BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my $json_str = '{"var1":"val1","var2":["first_element",{"sub_element":"sub_val","sub_element2":"sub_val2"}],"var3":"val3"}'; my $json_obj = JSON->new->allow_nonref(1); my $data = $json_obj->decode($json_str); my $pass = 1; if ($data->{var1} eq 'val1' and $data->{var3} eq 'val3') { if ($data->{var2}) { my $array = $data->{var2}; if (ref($array) eq 'ARRAY') { if ($array->[0] eq 'first_element') { my $hash = $array->[1]; if (ref($hash) eq 'HASH') { unless ($hash->{sub_element} eq 'sub_val' and $hash->{sub_element2} eq 'sub_val2') { $pass = 0; } } else { $pass = 0; } } else { $pass = 0; } } else { $pass = 0; } } else { $pass = 0; } } ok($pass); $json_str = '"val1"'; $data = $json_obj->decode($json_str); ok($data eq 'val1'); $json_str = '567'; $data = $json_obj->decode($json_str); ok($data == 567); $json_str = "5e1"; $data = $json_obj->decode($json_str); ok($data == 50); $json_str = "5e3"; $data = $json_obj->decode($json_str); ok($data == 5000); $json_str = "5e+1"; $data = $json_obj->decode($json_str); ok($data == 50); $json_str = "5e-1"; $data = $json_obj->decode($json_str); ok($data == 0.5); # use Data::Dumper; # print STDERR Dumper($test_data) . "\n\n"; } exit 0; ############################################################################### # Subroutines ��x16_tied.t��0000644��00000000616�15125143236�0006361 0��ustar�00��use strict; use Test::More; BEGIN { plan tests => 2 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= 1; } use JSON; use Tie::Hash; use Tie::Array; SKIP: { skip "can't use JSON::XS.", 2, unless( JSON->backend->is_xs ); my $js = JSON->new; tie my %h, 'Tie::StdHash'; %h = (a => 1); ok ($js->encode (\%h) eq '{"a":1}'); tie my @a, 'Tie::StdArray'; @a = (1, 2); ok ($js->encode (\@a) eq '[1,2]'); } ��03_types.t��0000644��00000004760�15125143236�0006410 0��ustar�00��# copied over from JSON::XS and modified to use JSON use strict; use warnings; use Test::More; BEGIN { plan tests => 78 + 2 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use utf8; use JSON; ok (!defined JSON->new->allow_nonref (1)->decode ('null')); ok (JSON->new->allow_nonref (1)->decode ('true') == 1); ok (JSON->new->allow_nonref (1)->decode ('false') == 0); my $true = JSON->new->allow_nonref (1)->decode ('true'); ok ($true eq 1); ok (JSON::is_bool $true); my $false = JSON->new->allow_nonref (1)->decode ('false'); ok ($false == !$true); ok (JSON::is_bool $false); ok (++$false == 1); ok (!JSON::is_bool $false); ok (!JSON::is_bool "JSON::Boolean"); ok (!JSON::is_bool {}); # GH-34 ok (JSON->new->allow_nonref (1)->decode ('5') == 5); ok (JSON->new->allow_nonref (1)->decode ('-5') == -5); ok (JSON->new->allow_nonref (1)->decode ('5e1') == 50); ok (JSON->new->allow_nonref (1)->decode ('-333e+0') == -333); ok (JSON->new->allow_nonref (1)->decode ('2.5') == 2.5); ok (JSON->new->allow_nonref (1)->decode ('""') eq ""); ok ('[1,2,3,4]' eq encode_json decode_json ('[1,2, 3,4]')); ok ('[{},[],[],{}]' eq encode_json decode_json ('[{},[], [ ] ,{ }]')); ok ('[{"1":[5]}]' eq encode_json [{1 => [5]}]); ok ('{"1":2,"3":4}' eq JSON->new->canonical (1)->encode (decode_json '{ "1" : 2, "3" : 4 }')); ok ('{"1":2,"3":1.2}' eq JSON->new->canonical (1)->encode (decode_json '{ "1" : 2, "3" : 1.2 }')); ok ('[true]' eq encode_json [JSON::true]); ok ('[false]' eq encode_json [JSON::false]); ok ('[true]' eq encode_json [\1]); ok ('[false]' eq encode_json [\0]); ok ('[null]' eq encode_json [undef]); ok ('[true]' eq encode_json [JSON::true]); ok ('[false]' eq encode_json [JSON::false]); SKIP: { skip "core booleans not supported", 2 unless JSON->backend->can("CORE_BOOL") && JSON->backend->CORE_BOOL; ok ('[true]' eq encode_json [!!1]); ok ('[false]' eq encode_json [!!0]); } for my $v (1, 2, 3, 5, -1, -2, -3, -4, 100, 1000, 10000, -999, -88, -7, 7, 88, 999, -1e5, 1e6, 1e7, 1e8) { ok ($v == ((decode_json "[$v]")->[0])); ok ($v == ((decode_json encode_json [$v])->[0])); } ok (30123 == ((decode_json encode_json [30123])->[0])); ok (32123 == ((decode_json encode_json [32123])->[0])); ok (32456 == ((decode_json encode_json [32456])->[0])); ok (32789 == ((decode_json encode_json [32789])->[0])); ok (32767 == ((decode_json encode_json [32767])->[0])); ok (32768 == ((decode_json encode_json [32768])->[0])); my @sparse; @sparse[0,3] = (1, 4); ok ("[1,null,null,4]" eq encode_json \@sparse); ��20_unknown.t��0000644��00000002073�15125143236�0006735 0��ustar�00��use strict; use warnings; use Test::More; BEGIN { plan tests => 10 }; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my $json = JSON->new; eval q\| $json->encode( [ sub {} ] ) \|; ok( $@ =~ /encountered CODE/, $@ ); eval q\| $json->encode( [ \-1 ] ) \|; ok( $@ =~ /cannot encode reference to scalar/, $@ ); eval q\| $json->encode( [ \undef ] ) \|; ok( $@ =~ /cannot encode reference to scalar/, $@ ); eval q\| $json->encode( [ \{} ] ) \|; ok( $@ =~ /cannot encode reference to scalar/, $@ ); $json->allow_unknown; is( $json->encode( [ sub {} ] ), '[null]' ); is( $json->encode( [ \-1 ] ), '[null]' ); is( $json->encode( [ \undef ] ), '[null]' ); is( $json->encode( [ \{} ] ), '[null]' ); SKIP: { skip "this test is for Perl 5.8 or later", 2 if( $] < 5.008 ); $json->allow_unknown(0); my $fh; open( $fh, '>hoge.txt' ) or die $!; eval q\| $json->encode( [ $fh ] ) \|; ok( $@ =~ /encountered GLOB\|cannot encode reference to scalar/, $@ ); $json->allow_unknown(1); is( $json->encode( [ $fh ] ), '[null]' ); close $fh; unlink('hoge.txt'); } ��20_faihu.t��0000644��00000002063�15125143236�0006331 0��ustar�00��# copied over from JSON::XS and modified to use JSON # adapted from a test by Aristotle Pagaltzis (http://intertwingly.net/blog/2007/11/15/Astral-Plane-Characters-in-Json) use strict; use warnings; BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } BEGIN { if ($] < 5.008) { require Test::More; Test::More::plan(skip_all => "requires Perl 5.8 or later"); } }; use JSON; use Encode qw(encode decode); use Test::More tests => 3; my ($faihu, $faihu_json, $roundtrip, $js) = "\x{10346}"; $js = JSON->new->allow_nonref->ascii; $faihu_json = $js->encode($faihu); $roundtrip = $js->decode($faihu_json); is ($roundtrip, $faihu, 'JSON in ASCII roundtrips correctly'); $js = JSON->new->allow_nonref->utf8; $faihu_json = $js->encode ($faihu); $roundtrip = $js->decode ($faihu_json); is ($roundtrip, $faihu, 'JSON in UTF-8 roundtrips correctly'); $js = JSON->new->allow_nonref; $faihu_json = encode 'UTF-16BE', $js->encode ($faihu); $roundtrip = $js->decode( decode 'UTF-16BE', $faihu_json); is ($roundtrip, $faihu, 'JSON with external recoding roundtrips correctly' ); ��gh_28_json_test_suite.t��0000644��00000002546�15125143236�0011152 0��ustar�00��# the following test cases are taken from JSONTestSuite # by Nicolas Seriot (https://github.com/nst/JSONTestSuite) use strict; use warnings; use Test::More; BEGIN { plan skip_all => 'this test is for Perl 5.8 or later' if $] < 5.008; } BEGIN { plan tests => 20 }; BEGIN { $ENV{PERL_JSON_BACKEND} = "JSON::backportPP"; } use JSON; my $DECODER = JSON->new->utf8->allow_nonref; # n_multidigit_number_then_00 decode_should_fail(qq!123\x00!); # number_-01 decode_should_fail(qq![-01]!); # number_neg_int_starting_with_zero decode_should_fail(qq![-012]!); # n_object_trailing_comment decode_should_fail(qq!{"a":"b"}//!); # n_object_trailing_comment_slash_open decode_should_fail(qq!{"a":"b"}//!); # n_structure_null-byte-outside-sting decode_should_fail(qq![\x00]!); # n_structure_object_with_comment decode_should_fail(qq!{"a":/comment/"b"}!); # n_structure_whitespace_formfeed decode_should_fail(qq![\0x0c]!); # y_string_utf16BE_no_BOM decode_should_pass(qq!\x00[\x00"\x00\xE9\x00"\x00]!); # y_string_utf16LE_no_BOM decode_should_pass(qq![\x00"\x00\xE9\x00"\x00]\x00!); sub decode_should_pass { my $json = shift; my $result = eval { $DECODER->decode($json); }; ok !$@, $@ \|\| ''; ok defined $result; } sub decode_should_fail { my $json = shift; my $result = eval { $DECODER->decode($json); }; ok $@, $@ \|\| ''; ok !defined $result; } ��114_decode_prefix.t��0000644��00000001572�15125143236�0010125 0��ustar�00��use strict; use warnings; use Test::More tests => 8; BEGIN { $ENV{ PERL_JSON_BACKEND } = 0; } BEGIN { $ENV{PERL_JSON_BACKEND} \|\|= "JSON::backportPP"; } use JSON; my $json = JSON->new; my $complete_text = qq/{"foo":"bar"}/; my $garbaged_text = qq/{"foo":"bar"}\n/; my $garbaged_text2 = qq/{"foo":"bar"}\n\n/; my $garbaged_text3 = qq/{"foo":"bar"}\n----/; is( ( $json->decode_prefix( $complete_text ) ) [1], 13 ); is( ( $json->decode_prefix( $garbaged_text ) ) [1], 13 ); is( ( $json->decode_prefix( $garbaged_text2 ) ) [1], 13 ); is( ( $json->decode_prefix( $garbaged_text3 ) ) [1], 13 ); eval { $json->decode( "\n" ) }; ok( $@ =~ /malformed JSON/ ); eval { $json->allow_nonref(0)->decode('null') }; ok $@ =~ /allow_nonref/; eval { $json->decode_prefix( "\n" ) }; ok( $@ =~ /malformed JSON/ ); eval { $json->allow_nonref(0)->decode_prefix('null') }; ok $@ =~ /allow_nonref/; ��pod-coverage.t��0000644��00000001220�15125143236�0007301 0��ustar�00��use strict; use warnings; use Test::More; unless ( $ENV{RELEASE_TESTING} ) { plan( skip_all => "Release tests not required for installation" ); } # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok(); ��0-basic.t��0000644��00000000705�15125143236�0006153 0��ustar�00��#!perl -T use 5.006; use strict; use warnings; use Test::More; plan tests => 3; use Config; ok($Config{startperl}, 'initial state'); use Mock::Config; # no lexical state yet, just dynamic Mock::Config->import(startperl => ''); diag( "Testing Mock::Config, Perl $], ". (exists &Config::KEYS ? 'XS' : '')."Config $Config::VERSION, $^X" ); is($Config{startperl}, '', 'mocked to empty'); Mock::Config->unimport; ok($Config{startperl}, 'reset'); ��date.t��0000644��00000012705�15125143260�0005652 0��ustar�00��#!perl use strict; use warnings; use Test::More tests => 141; use HTTP::Date; # test str2time for supported dates. Test cases with 2 digit year # will probably break in year 2044. my (@tests) = ( 'Thu Feb 3 00:00:00 GMT 1994', # ctime format 'Thu Feb 3 00:00:00 1994', # same as ctime, except no TZ 'Thu, 03 Feb 1994 00:00:00 GMT', # proposed new HTTP format 'Thursday, 03-Feb-94 00:00:00 GMT', # old rfc850 HTTP format 'Thursday, 03-Feb-1994 00:00:00 GMT', # broken rfc850 HTTP format '03/Feb/1994:00:00:00 0000', # common logfile format '03/Feb/1994:01:00:00 +0100', # common logfile format '02/Feb/1994:23:00:00 -0100', # common logfile format '03 Feb 1994 00:00:00 GMT', # HTTP format (no weekday) '03-Feb-94 00:00:00 GMT', # old rfc850 (no weekday) '03-Feb-1994 00:00:00 GMT', # broken rfc850 (no weekday) '03-Feb-1994 00:00 GMT', # broken rfc850 (no weekday, no seconds) '03-Feb-1994 00:00', # VMS dir listing format '03-Feb-94', # old rfc850 HTTP format (no weekday, no time) '03-Feb-1994', # broken rfc850 HTTP format (no weekday, no time) '03 Feb 1994', # proposed new HTTP format (no weekday, no time) '03/Feb/1994', # common logfile format (no time, no offset) #'Feb 3 00:00', # Unix 'ls -l' format (can't really test it here) 'Feb 3 1994', # Unix 'ls -l' format "02-03-94 12:00AM", # Windows 'dir' format "02-03-1994 12:00AM", # Windows 'dir' format with four-digit year # ISO 8601 formats '1994-02-03 00:00:00 +0000', '1994-02-03', '19940203', '1994-02-03T00:00:00+0000', '1994-02-02T23:00:00-0100', '1994-02-02T23:00:00-01:00', '1994-02-03T00:00:00 Z', '19940203T000000Z', '199402030000', # A few tests with extra space at various places ' 03/Feb/1994 ', ' 03 Feb 1994 0:00 ', # Tests a commonly used (faulty?) date format of php cms systems 'Thu, 03 Feb 1994 00:00:00 +0000 GMT' ); my $time = 760233600; # assume broken POSIX counting of seconds for (@tests) { my $t; if (/GMT/i) { $t = str2time($_); } else { $t = str2time( $_, "GMT" ); } my $t2 = str2time( lc($_), "GMT" ); my $t3 = str2time( uc($_), "GMT" ); note "\n'$_'"; is( $t, $time ); is( $t2, $time ); is( $t3, $time ); } # test time2str is( time2str($time), 'Thu, 03 Feb 1994 00:00:00 GMT' ); # test the 'ls -l' format with missing year$ # round to nearest minute 3 days ago. my $passed = 0; # Put in a hack to make the test pass due to daylight savings time affecting # the result for my $day ( 3 .. 4 ) { $time = int( ( time - $day * 24 * 60 * 60 ) / 60 ) * 60; my ( $min, $hr, $mday, $mon ) = ( localtime $time )[ 1, 2, 3, 4 ]; $mon = (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$mon]; my $str = sprintf( "$mon %02d %02d:%02d", $mday, $hr, $min ); my $t = str2time($str); if ( $t == $time ) { $passed = 1; last; } } ok($passed); # try some garbage. for ( undef, '', 'Garbage', 'Mandag 16. September 1996', '12 Arp 2003', # 'Thu Feb 3 00:00:00 CET 1994', # 'Thu, 03 Feb 1994 00:00:00 CET', # 'Wednesday, 31-Dec-69 23:59:59 GMT', '1980-00-01', '1980-13-01', '1980-01-00', '1980-01-32', '1980-01-01 25:00:00', '1980-01-01 00:61:00', '1980-01-01 00:00:61', ) { my $bad = 0; eval { if ( defined str2time $_) { print "str2time($_) is not undefined\n"; $bad++; } }; note defined($_) ? "\n'$_'" : "undef"; ok( !$@ ); ok( !$bad ); } note "Testing AM/PM gruff..."; # Test the str2iso routines use HTTP::Date qw(time2iso time2isoz); note "Testing time2iso functions"; my $t = time2iso( str2time("11-12-96 0:00AM") ); is( $t, "1996-11-12 00:00:00" ); $t = time2iso( str2time("11-12-96 12:00AM") ); is( $t, "1996-11-12 00:00:00" ); $t = time2iso( str2time("11-12-96 0:00PM") ); is( $t, "1996-11-12 12:00:00" ); $t = time2iso( str2time("11-12-96 12:00PM") ); is( $t, "1996-11-12 12:00:00" ); $t = time2iso( str2time("11-12-96 1:05AM") ); is( $t, "1996-11-12 01:05:00" ); $t = time2iso( str2time("11-12-96 12:05AM") ); is( $t, "1996-11-12 00:05:00" ); $t = time2iso( str2time("11-12-96 1:05PM") ); is( $t, "1996-11-12 13:05:00" ); $t = time2iso( str2time("11-12-96 12:05PM") ); is( $t, "1996-11-12 12:05:00" ); $t = time2iso( str2time("11-12-01 12:00PM") ); is( $t, "2001-11-12 12:00:00" ); $t = time2iso( str2time("11-12-1996 12:00AM") ); is( $t, "1996-11-12 00:00:00" ); $t = time2iso( str2time("11-12-2022 12:00AM") ); is( $t, "2022-11-12 00:00:00" ); $t = str2time("2000-01-01 00:00:01.234"); note "FRAC $t = ", time2iso($t); cmp_ok( abs( ( $t - int($t) ) - 0.234 ), '<', 0.000001 ); $a = time2iso; $b = time2iso(500000); note "LOCAL $a $b"; my $az = time2isoz; my $bz = time2isoz(500000); note "GMT $az $bz"; for ( $a, $b ) { like($_, qr/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\d$/); } for ( $az, $bz ) { like($_, qr/^\d{4}-\d\d-\d\d \d\d:\d\d:\d\dZ$/); } # Test the parse_date interface use HTTP::Date qw(parse_date); my @d = parse_date("Jan 1 2001"); is_deeply( \@d, [2001, 1, 1, 0, 0, 0, undef] ); # This test will break around year 2070 is( parse_date("03-Feb-20"), "2020-02-03 00:00:00" ); # This test will break around year 2048 is( parse_date("03-Feb-98"), "1998-02-03 00:00:00" ); note "HTTP::Date $HTTP::Date::VERSION"; ��00-compile.t��0000644��00000002632�15125143260�0006600 0��ustar�00��use 5.006; use strict; use warnings; # this test was generated with Dist::Zilla::Plugin::Test::Compile 2.058 use Test::More; plan tests => 1 + ($ENV{AUTHOR_TESTING} ? 1 : 0); my @module_files = ( 'HTTP/Date.pm' ); # no fake home requested my @switches = ( -d 'blib' ? '-Mblib' : '-Ilib', ); use File::Spec; use IPC::Open3; use IO::Handle; open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; my @warnings; for my $lib (@module_files) { # see L<perlfaq8/How can I capture STDERR from an external command?> my $stderr = IO::Handle->new; diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} } $^X, @switches, '-e', "require q[$lib]")) if $ENV{PERL_COMPILE_TEST_DEBUG}; my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-e', "require q[$lib]"); binmode $stderr, ':crlf' if $^O eq 'MSWin32'; my @_warnings = <$stderr>; waitpid($pid, 0); is($?, 0, "$lib loaded ok"); shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .\bblib/ and not eval { +require blib; blib->VERSION('1.01') }; if (@_warnings) { warn @_warnings; push @warnings, @_warnings; } } is(scalar(@warnings), 0, 'no warnings found') or diag 'got warnings: ', ( Test::More->can('explain') ? Test::More::explain(\@warnings) : join("\n", '', @warnings) ) if $ENV{AUTHOR_TESTING}; ��regexp.t��0000644��00000007250�15125143264�0006232 0��ustar�00��#!perl -w use strict; use Storable "dclone"; use Test::More; my $version = int(($]-5)1000); $version >= 8 or plan skip_all => "regexps not supported before 5.8"; my @tests; while (<DATA>) { chomp; next if /^\s#/ \|\| !/\S/; my ($range, $code, $match, $name) = split /\s;\s/; defined $name or die "Bad test line"; my $ascii_only = $range =~ s/A//; next if $ascii_only and ord("A") != 65; if ($range =~ /^(\d+)-$/) { next if $version < $1 } elsif ($range =~ /^-(\d+)$/) { next if $version > $1 } elsif ($range =~ /^(\d+)-(\d+)$/) { next if $version < $1 \|\| $version > $2; } elsif ($range ne "-") { die "Invalid version range $range for $name"; } my @match = split /\s,\s/, $match; for my $m (@match) { my $not = $m =~ s/^!//; my $cmatch = eval $m; die if $@; push @tests, [ $code, $not, $cmatch, $m, $name ]; } } plan tests => 10 + 3scalar(@tests); SKIP: { $version >= 14 && $version < 20 or skip "p introduced in 5.14, pointless from 5.20", 4; my $q1 = eval "qr/b/p"; my $q2 = eval "qr/b/"; my $c1 = dclone($q1); my $c2 = dclone($q2); ok("abc" =~ $c1, "abc matches $c1"); is(${^PREMATCH}, "a", "check p worked"); ok("cba" =~ $c2, "cba matches $c2"); isnt(${^PREMATCH}, "c", "check no p worked"); } SKIP: { $version >= 24 or skip "n introduced in 5.22", 4; my $c1 = dclone(eval "qr/(\\w)/"); my $c2 = dclone(eval "qr/(\\w)/n"); ok("a" =~ $c1, "a matches $c1"); is($1, "a", "check capturing preserved"); ok("b" =~ $c2, "b matches $c2"); isnt($1, "b", "check non-capturing preserved"); } SKIP: { $version >= 8 or skip "Cannot retrieve before 5.8", 1; my $x; my $re = qr/a(?{ $x = 1 })/; use re 'eval'; ok(!eval { dclone($re) }, "should fail to clone, even with use re 'eval'"); } is(ref(dclone(bless qr//, "Foo")), "Foo", "check reblessed regexps"); for my $test (@tests) { my ($code, $not, $match, $matchc, $name) = @$test; my $qr = eval $code; die "Could not compile $code: $@" if $@; if ($not) { unlike($match, $qr, "$name: pre(not) match $matchc"); } else { like($match, $qr, "$name: prematch $matchc"); } my $qr2 = dclone($qr); if ($not) { unlike($match, $qr2, "$name: (not) match $matchc"); } else { like($match, $qr2, "$name: match $matchc"); } # this is unlikely to be a problem, but make sure regexps are frozen sanely # as part of a data structure my $a2 = dclone([ $qr ]); if ($not) { unlike($match, $a2->[0], "$name: (not) match $matchc (array)"); } else { like($match, $a2->[0], "$name: match $matchc (array)"); } } __DATA__ # semi-colon separated: # perl version range; regexp qr; match string; name # - version range is PERL_VERSION, ie 22 for 5.22 as from-to with both from # and to optional (so "-" is all versions. # - match string is , separated match strings # - if a match string starts with ! it mustn't match, otherwise it must # spaces around the commas ignored. # The initial "!" is stripped and the remainder treated as perl code to define # the string to (not) be matched -; qr/foo/ ; "foo",!"fob" ; simple -; qr/foo/i ; "foo","FOO",!"fob" ; simple case insensitive -; qr/f o o/x ; "foo", !"f o o" ; /x -; qr(a/b) ; "a/b" ; alt quotes A-; qr(\x2E) ; ".", !"a" ; \x2E - hex meta -; qr/\./ ; "." , !"a" ; \. - backslash meta 8- ; qr/\x{100}/ ; "\x{100}" ; simple unicode A12- ; qr/fss/i ; "f\xDF\x{101}" ; case insensive unicode promoted A22-; qr/fss/ui ; "f\xDF" ; case insensitive unicode SS /iu A22-; qr/fss/aai ; !"f\xDF" ; case insensitive unicode SS /iaa A22-; qr/f\w/a ; "fo", !"f\xff" ; simple /a flag ��hugeids.t��0000644��00000017154�15125143264�0006374 0��ustar�00��#!./perl # We do all of the work in child processes here to ensure that any # memory used is released immediately. # These tests use ridiculous amounts of memory and CPU. use strict; use warnings; use Config; use Storable qw(store_fd retrieve_fd nstore_fd); use Test::More; use File::Temp qw(tempfile); use File::Spec; BEGIN { plan skip_all => 'Storable was not built' if $ENV{PERL_CORE} && $Config{'extensions'} !~ /\b Storable \b/x; plan skip_all => 'Need 64-bit pointers for this test' if $Config{ptrsize} < 8 and $] > 5.013; plan skip_all => 'Need 64-bit int for this test on older versions' if $Config{uvsize} < 8 and $] < 5.013; plan skip_all => 'Need ~8 GiB memory for this test, set PERL_TEST_MEMORY >= 8' if !$ENV{PERL_TEST_MEMORY} \|\| $ENV{PERL_TEST_MEMORY} < 8; plan skip_all => 'These tests are slow, set PERL_RUN_SLOW_TESTS' unless $ENV{PERL_RUN_SLOW_TESTS}; plan skip_all => "Need fork for this test", unless $Config{d_fork}; } find_exe("gzip") or plan skip_all => "Need gzip for this test"; find_exe("gunzip") or plan skip_all => "Need gunzip for this test"; plan tests => 12; my $skips = $ENV{PERL_STORABLE_SKIP_ID_TEST} \|\| ''; my $keeps = $ENV{PERL_STORABLE_KEEP_ID_TEST}; freeze_thaw_test ( name => "object ids between 2G and 4G", freeze => \&make_2g_data, thaw => \&check_2g_data, id => "2g", memory => 34, ); freeze_thaw_test ( name => "object ids over 4G", freeze => \&make_4g_data, thaw => \&check_4g_data, id => "4g", memory => 70, ); freeze_thaw_test ( name => "hook object ids over 4G", freeze => \&make_hook_data, thaw => \&check_hook_data, id => "hook4g", memory => 70, ); # not really an id test, but the infrastructure here makes tests # easier freeze_thaw_test ( name => "network store large PV", freeze => \&make_net_large_pv, thaw => \&check_net_large_pv, id => "netlargepv", memory => 8, ); freeze_thaw_test ( name => "hook store with 2g data", freeze => \&make_2g_hook_data, thaw => \&check_2g_hook_data, id => "hook2gdata", memory => 4, ); freeze_thaw_test ( name => "hook store with 4g data", freeze => \&make_4g_hook_data, thaw => \&check_4g_hook_data, id => "hook4gdata", memory => 8, ); sub freeze_thaw_test { my %opts = @_; my $freeze = $opts{freeze} or die "Missing freeze"; my $thaw = $opts{thaw} or die "Missing thaw"; my $id = $opts{id} or die "Missing id"; my $name = $opts{name} or die "Missing name"; my $memory = $opts{memory} or die "Missing memory"; my $todo_thaw = $opts{todo_thaw} \|\| ""; SKIP: { # IPC::Run would be handy here $ENV{PERL_TEST_MEMORY} >= $memory or skip "Not enough memory to test $name", 2; $skips =~ /\b\Q$id\E\b/ and skip "You requested test $name ($id) be skipped", 2; defined $keeps && $keeps !~ /\b\Q$id\E\b/ and skip "You didn't request test $name ($id)", 2; my $stored; if (defined(my $pid = open(my $fh, "-\|"))) { unless ($pid) { # child open my $cfh, "\|-", "gzip" or die "Cannot pipe to gzip: $!"; binmode $cfh; $freeze->($cfh); exit; } # parent $stored = do { local $/; <$fh> }; close $fh; } else { skip "$name: Cannot fork for freeze", 2; } ok($stored, "$name: we got output data") or skip "$name: skipping thaw test", 1; my ($tfh, $tname) = tempfile(); #my $tname = "$id.store.gz"; #open my $tfh, ">", $tname or die; #binmode $tfh; print $tfh $stored; close $tfh; if (defined(my $pid = open(my $fh, "-\|"))) { unless ($pid) { # child open my $bfh, "-\|", "gunzip <$tname" or die "Cannot pipe from gunzip: $!"; binmode $bfh; $thaw->($bfh); exit; } my $out = do { local $/; <$fh> }; chomp $out; local $TODO = $todo_thaw; is($out, "OK", "$name: check result"); } else { skip "$name: Cannot fork for thaw", 1; } } } sub make_2g_data { my ($fh) = @_; my @x; my $y = 1; my $z = 2; my $g2 = 0x80000000; $x[0] = \$y; $x[$g2] = \$y; $x[$g2+1] = \$z; $x[$g2+2] = \$z; store_fd(\@x, $fh); } sub check_2g_data { my ($fh) = @_; my $x = retrieve_fd($fh); my $g2 = 0x80000000; $x->[0] == $x->[$g2] or die "First entry mismatch"; $x->[$g2+1] == $x->[$g2+2] or die "2G+ entry mismatch"; print "OK"; } sub make_4g_data { my ($fh) = @_; my @x; my $y = 1; my $z = 2; my $g4 = 20x80000000; $x[0] = \$y; $x[$g4] = \$y; $x[$g4+1] = \$z; $x[$g4+2] = \$z; store_fd(\@x, $fh); } sub check_4g_data { my ($fh) = @_; my $x = retrieve_fd($fh); my $g4 = 20x80000000; $x->[0] == $x->[$g4] or die "First entry mismatch"; $x->[$g4+1] == $x->[$g4+2] or die "4G+ entry mismatch"; ${$x->[$g4+1]} == 2 or die "Incorrect value in 4G+ entry"; print "OK"; } sub make_hook_data { my ($fh) = @_; my @x; my $y = HookLargeIds->new(101, { name => "one" }); my $z = HookLargeIds->new(201, { name => "two" }); my $g4 = 20x8000_0000; $x[0] = $y; $x[$g4] = $y; $x[$g4+1] = $z; $x[$g4+2] = $z; store_fd(\@x, $fh); } sub check_hook_data { my ($fh) = @_; my $x = retrieve_fd($fh); my $g4 = 20x8000_0000; my $y = $x->[$g4+1]; $y = $x->[$g4+1]; $y->id == 201 or die "Incorrect id in 4G+ object"; ref($y->data) eq 'HASH' or die "data isn't a ref"; $y->data->{name} eq "two" or die "data name not 'one'"; print "OK"; } sub make_net_large_pv { my ($fh) = @_; my $x = "x"; # avoid constant folding making a 4G scalar my $g4 = 20x80000000; my $y = $x x ($g4 + 5); nstore_fd(\$y, $fh); } sub check_net_large_pv { my ($fh) = @_; my $x = retrieve_fd($fh); my $g4 = 20x80000000; ref $x && ref($x) eq "SCALAR" or die "Not a scalar ref ", ref $x; length($$x) == $g4+5 or die "Incorect length"; print "OK"; } sub make_2g_hook_data { my ($fh) = @_; my $g2 = 0x80000000; my $x = HookLargeData->new($g2); store_fd($x, $fh); } sub check_2g_hook_data { my ($fh) = @_; my $x = retrieve_fd($fh); my $g2 = 0x80000000; $x->size == $g2 or die "Size incorrect ", $x->size; print "OK"; } sub make_4g_hook_data { my ($fh) = @_; my $g2 = 0x80000000; my $g4 = 2 * $g2; my $x = HookLargeData->new($g4+1); store_fd($x, $fh); } sub check_4g_hook_data { my ($fh) = @_; my $x = retrieve_fd($fh); my $g2 = 0x80000000; my $g4 = 2 * $g2; $x->size == $g4+1 or die "Size incorrect ", $x->size; print "OK"; } sub find_exe { my ($exe) = @_; $exe .= $Config{_exe}; my @path = split /\Q$Config{path_sep}/, $ENV{PATH}; for my $dir (@path) { my $abs = File::Spec->catfile($dir, $exe); -x $abs and return $abs; } } package HookLargeIds; sub new { my $class = shift; my ($id, $data) = @_; return bless { id => $id, data => $data }, $class; } sub STORABLE_freeze { #print STDERR "freeze called\n"; #Devel::Peek::Dump($_[0]); return $_[0]->id, $_[0]->data; } sub STORABLE_thaw { my ($self, $cloning, $ser, $data) = @_; #Devel::Peek::Dump(\@_); #print STDERR "thaw called\n"; #Devel::Peek::Dump($self); $self->{id} = $ser+0; $self->{data} = $data; } sub id { $_[0]{id}; } sub data { $_[0]{data}; } package HookLargeData; sub new { my ($class, $size) = @_; return bless { size => $size }, $class; } sub STORABLE_freeze { return "x" x $_[0]{size}; } sub STORABLE_thaw { my ($self, $cloning, $ser) = @_; $self->{size} = length $ser; } sub size { $_[0]{size}; } ��threads.t��0000644��00000003665�15125143264�0006400 0��ustar�00�� # as of 2.09 on win32 Storable w/threads dies with "free to wrong # pool" since it uses the same context for different threads. since # win32 perl implementation allocates a different memory pool for each # thread using the a memory pool from one thread to allocate memory # for another thread makes win32 perl very unhappy # # but the problem exists everywhere, not only on win32 perl , it's # just hard to catch it deterministically - since the same context is # used if two or more threads happen to change the state of the # context in the middle of the operation, and those operations aren't # atomic per thread, bad things including data loss and corrupted data # can happen. # # this has been solved in 2.10 by adding a Storable::CLONE which calls # Storable::init_perinterp() to create a new context for each new # thread when it starts sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } unless ($Config{'useithreads'} and eval { require threads; 1 }) { print "1..0 # Skip: no threads\n"; exit 0; } if ($] eq "5.008" \|\| $] eq "5.010000") { print "1..0 # Skip: threads unreliable in perl-$]\n"; exit 0; } # - is \W, so can't use \b at start. Negative look ahead and look behind # works at start/end of string, or where preceded/followed by spaces if ($] == 5.008002 and eval q{ $Config{'ccflags'} =~ /(?<!\S)-DDEBUGGING(?!\S)/ }) { # Bug caused by change 21610, fixed by change 21849 print "1..0 # Skip: tickles bug in threads combined with -DDEBUGGING on 5.8.2\n"; exit 0; } } use Test::More; use strict; use threads; use Storable qw(nfreeze); plan tests => 2; threads->new(\&sub1); $_->join() for threads->list(); ok 1; sub sub1 { nfreeze {}; ok 1; } ��interwork56.t��0000644��00000013712�15125143264�0007137 0��ustar�00��#!./perl -w # # Copyright 2002, Larry Wall. # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # # I ought to keep this test easily backwards compatible to 5.004, so no # qr//; # This test checks whether the kludge to interwork with 5.6 Storables compiled # on Unix systems with IV as long long works. sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } unless ($Config{ivsize} and $Config{ivsize} > $Config{longsize}) { print "1..0 # Skip: Your IVs are no larger than your longs\n"; exit 0; } } use Storable qw(freeze thaw); use strict; use Test::More tests=>30; our (%tests); { local $/ = "\n\nend\n"; while (<DATA>) { next unless /\S/s; unless (/begin ([0-7]{3}) ([^\n])\n(.)$/s) { s/\n.//s; warn "Dodgy data in section starting '$_'"; next; } next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa my $data = unpack 'u', $3; $tests{$2} = $data; } } # perl makes easy things easy, and hard things possible: my $test = freeze \'Hell'; my $header = Storable::read_magic ($test); is ($header->{byteorder}, $Config{byteorder}, "header's byteorder and Config.pm's should agree"); my $result = eval {thaw $test}; isa_ok ($result, 'SCALAR', "Check thawing test data"); is ($@, '', "causes no errors"); is ($$result, 'Hell', 'and gives the expected data'); my $kingdom = $Config{byteorder} =~ /23/ ? "Lillput" : "Belfuscu"; my $name = join ',', $kingdom, @$header{qw(intsize longsize ptrsize nvsize)}; SKIP: { my $real_thing = $tests{$name}; if (!defined $real_thing) { print << "EOM"; # No test data for Storable 1.x for: # # byteorder '$Config{byteorder}' # sizeof(int) $$header{intsize} # sizeof(long) $$header{longsize} # sizeof(char ) $$header{ptrsize} # sizeof(NV) $$header{nvsize} # If you have Storable 1.x built with perl 5.6.x on this platform, please # make_56_interwork.pl to generate test data, and append the test data to # this test. # You may find that make_56_interwork.pl reports that your platform has no # interworking problems, in which case you need do nothing. EOM skip "# No 1.x test file", 9; } my $result = eval {thaw $real_thing}; is ($result, undef, "By default should not be able to thaw"); like ($@, qr/Byte order is not compatible/, "because the header byte order strings differ"); local $Storable::interwork_56_64bit = 1; $result = eval {thaw $real_thing}; isa_ok ($result, 'ARRAY', "With flag should now thaw"); is ($@, '', "with no errors"); # However, as the file is written with Storable pre 2.01, it's a known # bug that large (positive) UVs become IVs my $value = (~0 ^ (~0 >> 1) ^ 2); is (@$result, 4, "4 elements in array"); like ($$result[0], qr/^This file was written with [0-9.]+ on perl [0-9.]+\z/, "1st element"); is ($$result[1], "$kingdom was correct", "2nd element"); cmp_ok ($$result[2] ^ $value, '==', 0, "3rd element") or printf "# expected %#X, got %#X\n", $value, $$result[2]; is ($$result[3], "The End", "4th element"); } $result = eval {thaw $test}; isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data"); is ($@, '', " causes no errors"); is ($$result, 'Hell', " and gives the expected data"); my $test_kludge; { local $Storable::interwork_56_64bit = 1; $test_kludge = freeze \'Heck'; } my $header_kludge = Storable::read_magic ($test_kludge); cmp_ok (length ($header_kludge->{byteorder}), '==', $Config{longsize}, "With 5.6 interwork kludge byteorder string should be same size as long" ); $result = eval {thaw $test_kludge}; is ($result, undef, "By default should not be able to thaw"); like ($@, qr/Byte order is not compatible/, "because the header byte order strings differ"); $result = eval {thaw $test}; isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data"); is ($@, '', " causes no errors"); is ($$result, 'Hell', " and gives the expected data"); { local $Storable::interwork_56_64bit = 1; $result = eval {thaw $test_kludge}; isa_ok ($result, 'SCALAR', "should be able to thaw kludge data"); is ($@, '', "with no errors"); is ($$result, 'Heck', "and gives expected data"); $result = eval {thaw $test}; is ($result, undef, "But now can't thaw real data"); like ($@, qr/Byte order is not compatible/, "because the header byte order strings differ"); } # All together now: $result = eval {thaw $test}; isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data"); is ($@, '', " causes no errors"); is ($$result, 'Hell', " and gives the expected data"); __END__ # A whole run of 1.1.14 freeze data, uuencoded. The "mode bits" are the octal # value of 'A', the "file name" is the test name. Use make_56_interwork.pl # with a copy of Storable 1.X generate these. # byteorder '1234' # sizeof(int) 4 # sizeof(long) 4 # sizeof(char ) 4 # sizeof(NV) 8 begin 101 Lillput,4,4,4,8 M!`0$,3(S-`0$!`@"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@ M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87,@8V]R<F5C=`8" 0````````@`H'5&AE($5N9``` end # byteorder '4321' # sizeof(int) 4 # sizeof(long) 4 # sizeof(char ) 4 # sizeof(NV) 8 begin 101 Belfuscu,4,4,4,8 M!`0$-#,R,00$!`@"````!`HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@ M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H40F5L9G5S8W4@=V%S(&-O<G)E8W0& 1@`````````(!U1H92!%;F0` end # byteorder '1234' # sizeof(int) 4 # sizeof(long) 4 # sizeof(char ) 4 # sizeof(NV) 12 begin 101 Lillput,4,4,4,12 M!`0$,3(S-`0$!`P"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@ M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87,@8V]R<F5C=`8" 0````````@`H'5&AE($5N9``` end ��tied_reify.t��0000644��00000001155�15125143264�0007061 0��ustar�00��use Test::More tests => 1; package dumb_thing; use strict; use warnings; use Tie::Array; use Carp; use base 'Tie::StdArray'; sub TIEARRAY { my $class = shift; my $this = bless [], $class; my $that = shift; @$this = @$that; $this; } package main; use strict; use warnings; use Storable qw(freeze thaw); my $x = [1,2,3,4]; broken($x); # ties $x broken( thaw( freeze($x) ) ); # since 5.16 fails with "Cannot tie unreifiable array" sub broken { my $w = shift; tie @$_, dumb_thing => $_ for $w; } # fails since 5.16 ok 1, 'Does not fail with "Cannot tie unreifiable array" RT#84705'; ��make_overload.pl��0000644��00000000261�15125143264�0007713 0��ustar�00��#!/usr/local/bin/perl -w use strict; use Storable qw(nfreeze); use HAS_OVERLOAD; my $o = HAS_OVERLOAD->make("snow"); my $f = nfreeze \$o; my $uu = pack 'u', $f; print $uu; ��utf8.t��0000644��00000001037�15125143264�0005623 0��ustar�00��use strict; use warnings; use utf8; use Test::More 'no_plan'; use URI (); is(URI->new('http://foobar/mooi€e')->as_string, 'http://foobar/mooi%E2%82%ACe'); my $uri = URI->new('http:'); $uri->query_form("mooi€e" => "mooi€e"); is( $uri->query, "mooi%E2%82%ACe=mooi%E2%82%ACe" ); is( ($uri->query_form)[1], "mooi\xE2\x82\xACe" ); # RT#70161 use Encode qw( decode_utf8 ); $uri = URI->new(decode_utf8 '?Query=%C3%A4%C3%B6%C3%BC'); is( ($uri->query_form)[1], "\xC3\xA4\xC3\xB6\xC3\xBC"); is( decode_utf8(($uri->query_form)[1]), 'äöü'); ��huge.t��0000644��00000006340�15125143264�0005667 0��ustar�00��#!./perl use strict; use warnings; use Config; use Storable qw(dclone); use Test::More; BEGIN { plan skip_all => 'Storable was not built' if $ENV{PERL_CORE} && $Config{'extensions'} !~ /\b Storable \b/x; plan skip_all => 'Need 64-bit pointers for this test' if $Config{ptrsize} < 8 and $] > 5.013; plan skip_all => 'Need 64-bit int for this test on older versions' if $Config{uvsize} < 8 and $] < 5.013; plan skip_all => 'Need ~4 GiB memory for this test, set PERL_TEST_MEMORY > 4' if !$ENV{PERL_TEST_MEMORY} \|\| $ENV{PERL_TEST_MEMORY} < 4; } # Just too big to fit in an I32. my $huge = int(2 ** 31); # v5.24.1c/v5.25.1c switched to die earlier with "Too many elements", # which is much safer. my $has_too_many = ($Config{usecperl} and (($] >= 5.024001 and $] < 5.025000) or $] >= 5.025001)) ? 1 : 0; # These overlarge sizes are enabled only since Storable 3.00 and some # cases need cperl support. Perl5 (as of 5.24) has some internal # problems with >I32 sizes, which only cperl has fixed. # perl5 is not yet 2GB safe, esp. with hashes. # string len (xpv_cur): STRLEN (ptrsize>=8) # array size (xav_max): SSize_t (I32/I64) (ptrsize>=8) # hash size (xhv_keys): # IV - 5.12 (ivsize>=8) # STRLEN 5.14 - 5.24 (size_t: U32/U64) # SSize_t 5.22c - 5.24c (I32/I64) # U32 5.25c - # hash key: I32 my @cases = ( ['huge string', sub { my $s = 'x' x $huge; \$s }], ['array with huge element', sub { my $s = 'x' x $huge; [$s] }], ['hash with huge value', sub { my $s = 'x' x $huge; +{ foo => $s } }], # There's no huge key, limited to I32. ) if $Config{ptrsize} > 4; # An array with a huge number of elements requires several gigabytes of # virtual memory. On darwin it is evtl killed. if ($Config{ptrsize} > 4 and !$has_too_many) { # needs 20-55G virtual memory, 4.6M heap and several minutes on a fast machine if ($ENV{PERL_TEST_MEMORY} >= 55) { push @cases, [ 'huge array', sub { my @x; $x[$huge] = undef; \@x } ]; } else { diag "skip huge array, need PERL_TEST_MEMORY >= 55"; } } # A hash with a huge number of keys would require tens of gigabytes of # memory, which doesn't seem like a good idea even for this test file. # Unfortunately even older 32bit perls do allow this. if (!$has_too_many) { # needs >90G virtual mem, and is evtl. killed if ($ENV{PERL_TEST_MEMORY} >= 96) { # number of keys >I32. impossible to handle with perl5, but Storable can. push @cases, ['huge hash', sub { my %x = (0 .. $huge); \%x } ]; } else { diag "skip huge hash, need PERL_TEST_MEMORY >= 96"; } } plan tests => 2 * scalar @cases; for (@cases) { my ($desc, $build) = @$_; diag "building test input: $desc"; my ($input, $exn, $clone); diag "these huge subtests need a lot of memory and time!" if $desc eq 'huge array'; $input = $build->(); diag "running test: $desc"; $exn = $@ if !eval { $clone = dclone($input); 1 }; is($exn, undef, "$desc no exception"); is_deeply($input, $clone, "$desc cloned"); #ok($clone, "$desc cloned"); # Ensure the huge objects are freed right now: undef $input; undef $clone; } ��blessed.t��0000644��00000025024�15125143264�0006360 0��ustar�00��#!./perl # # Copyright (c) 1995-2000, Raphael Manfredi # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # BEGIN { # Do this as the very first thing, in order to avoid problems with the # PADTMP flag on pre-5.19.3 threaded Perls. On those Perls, compiling # code that contains a constant-folded canonical truth value breaks # the ability to take a reference to that canonical truth value later. $::false = 0; %::immortals = ( 'u' => \undef, 'y' => \!$::false, 'n' => \!!$::false, ); } sub BEGIN { if ($ENV{PERL_CORE}) { chdir 'dist/Storable' if -d 'dist/Storable'; @INC = ('../../lib', 't'); } else { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; } require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use Test::More; use Storable qw(freeze thaw store retrieve fd_retrieve); %::weird_refs = (REF => \(my $aref = []), VSTRING => \(my $vstring = v1.2.3), 'long VSTRING' => \(my $lvstring = eval "v" . 0 x 300), LVALUE => \(my $substr = substr((my $str = "foo"), 0, 3))); my $test = 13; my $tests = $test + 41 + (2 * 6 * keys %::immortals) + (3 * keys %::weird_refs); plan(tests => $tests); package SHORT_NAME; sub make { bless [], shift } package SHORT_NAME_WITH_HOOK; sub make { bless [], shift } sub STORABLE_freeze { my $self = shift; return ("", $self); } sub STORABLE_thaw { my $self = shift; my $cloning = shift; my ($x, $obj) = @_; die "STORABLE_thaw" unless $obj eq $self; } package main; # Still less than 256 bytes, so long classname logic not fully exercised # Identifier too long - 5.004 # parser.h: char tokenbuf[256]: cperl5.24 => 1024 my $m = ($Config{usecperl} and $] >= 5.024) ? 56 : 14; my $longname = "LONG_NAME_" . ('xxxxxxxxxxxxx::' x $m) . "final"; eval <<EOC; package $longname; \@ISA = ("SHORT_NAME"); EOC is($@, ''); eval <<EOC; package ${longname}_WITH_HOOK; \@ISA = ("SHORT_NAME_WITH_HOOK"); EOC is($@, ''); # Construct a pool of objects my @pool; for (my $i = 0; $i < 10; $i++) { push(@pool, SHORT_NAME->make); push(@pool, SHORT_NAME_WITH_HOOK->make); push(@pool, $longname->make); push(@pool, "${longname}_WITH_HOOK"->make); } my $x = freeze \@pool; pass("Freeze didn't crash"); my $y = thaw $x; is(ref $y, 'ARRAY'); is(scalar @{$y}, @pool); is(ref $y->[0], 'SHORT_NAME'); is(ref $y->[1], 'SHORT_NAME_WITH_HOOK'); is(ref $y->[2], $longname); is(ref $y->[3], "${longname}_WITH_HOOK"); my $good = 1; for (my $i = 0; $i < 10; $i++) { do { $good = 0; last } unless ref $y->[4$i] eq 'SHORT_NAME'; do { $good = 0; last } unless ref $y->[4$i+1] eq 'SHORT_NAME_WITH_HOOK'; do { $good = 0; last } unless ref $y->[4$i+2] eq $longname; do { $good = 0; last } unless ref $y->[4$i+3] eq "${longname}_WITH_HOOK"; } is($good, 1); { my $blessed_ref = bless \\[1,2,3], 'Foobar'; my $x = freeze $blessed_ref; my $y = thaw $x; is(ref $y, 'Foobar'); is($$$y->[0], 1); } package RETURNS_IMMORTALS; sub make { my $self = shift; bless [@_], $self } sub STORABLE_freeze { # Some reference some number of times. my $self = shift; my ($what, $times) = @$self; return ("$what$times", ($::immortals{$what}) x $times); } sub STORABLE_thaw { my $self = shift; my $cloning = shift; my ($x, @refs) = @_; my ($what, $times) = $x =~ /(.)(\d+)/; die "'$x' didn't match" unless defined $times; main::is(scalar @refs, $times); my $expect = $::immortals{$what}; die "'$x' did not give a reference" unless ref $expect; my $fail; foreach (@refs) { $fail++ if $_ != $expect; } main::is($fail, undef); } package main; # XXX Failed tests: 15, 27, 39 with 5.12 and 5.10 threaded. # 15: 1 fail (y x 1), 27: 2 fail (y x 2), 39: 3 fail (y x 3) # $Storable::DEBUGME = 1; my $count; foreach $count (1..3) { my $immortal; foreach $immortal (keys %::immortals) { print "# $immortal x $count\n"; my $i = RETURNS_IMMORTALS->make ($immortal, $count); my $f = freeze ($i); TODO: { # ref sv_true is not always sv_true, at least in older threaded perls. local $TODO = "Some 5.10/12 do not preserve ref identity with freeze \\(1 == 1)" if !defined($f) and $] < 5.013 and $] > 5.009 and $immortal eq 'y'; isnt($f, undef); } my $t = thaw $f; pass("thaw didn't crash"); } } # Test automatic require of packages to find thaw hook. package HAS_HOOK; $loaded_count = 0; $thawed_count = 0; sub make { bless []; } sub STORABLE_freeze { my $self = shift; return ''; } package main; my $f = freeze (HAS_HOOK->make); is($HAS_HOOK::loaded_count, 0); is($HAS_HOOK::thawed_count, 0); my $t = thaw $f; is($HAS_HOOK::loaded_count, 1); is($HAS_HOOK::thawed_count, 1); isnt($t, undef); is(ref $t, 'HAS_HOOK'); delete $INC{"HAS_HOOK.pm"}; delete $HAS_HOOK::{STORABLE_thaw}; $t = thaw $f; is($HAS_HOOK::loaded_count, 2); is($HAS_HOOK::thawed_count, 2); isnt($t, undef); is(ref $t, 'HAS_HOOK'); { package STRESS_THE_STACK; my $stress; sub make { bless []; } sub no_op { 0; } sub STORABLE_freeze { my $self = shift; ++$freeze_count; return no_op(1..(++$stress * 2000)) ? die "can't happen" : ''; } sub STORABLE_thaw { my $self = shift; ++$thaw_count; no_op(1..(++$stress * 2000)) && die "can't happen"; return; } } $STRESS_THE_STACK::freeze_count = 0; $STRESS_THE_STACK::thaw_count = 0; $f = freeze (STRESS_THE_STACK->make); is($STRESS_THE_STACK::freeze_count, 1); is($STRESS_THE_STACK::thaw_count, 0); $t = thaw $f; is($STRESS_THE_STACK::freeze_count, 1); is($STRESS_THE_STACK::thaw_count, 1); isnt($t, undef); is(ref $t, 'STRESS_THE_STACK'); my $file = "storable-testfile.$$"; die "Temporary file '$file' already exists" if -e $file; END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }} $STRESS_THE_STACK::freeze_count = 0; $STRESS_THE_STACK::thaw_count = 0; store (STRESS_THE_STACK->make, $file); is($STRESS_THE_STACK::freeze_count, 1); is($STRESS_THE_STACK::thaw_count, 0); $t = retrieve ($file); is($STRESS_THE_STACK::freeze_count, 1); is($STRESS_THE_STACK::thaw_count, 1); isnt($t, undef); is(ref $t, 'STRESS_THE_STACK'); { package ModifyARG112358; sub STORABLE_freeze { $_[0] = "foo"; } my $o= {str=>bless {}}; my $f= ::freeze($o); ::is ref $o->{str}, __PACKAGE__, 'assignment to $_[0] in STORABLE_freeze does not corrupt things'; } # [perl #113880] { { package WeirdRefHook; sub STORABLE_freeze { () } $INC{'WeirdRefHook.pm'} = __FILE__; } for my $weird (keys %weird_refs) { my $obj = $weird_refs{$weird}; bless $obj, 'WeirdRefHook'; my $frozen; my $success = eval { $frozen = freeze($obj); 1 }; ok($success, "can freeze $weird objects") \|\| diag("freezing failed: $@"); my $thawn = thaw($frozen); # is_deeply ignores blessings is ref $thawn, ref $obj, "get the right blessing back for $weird"; if ($weird =~ 'VSTRING') { # It is not just Storable that did not support vstrings. :-) # See https://rt.cpan.org/Ticket/Display.html?id=78678 my $newver = "version"->can("new") ? sub { "version"->new(shift) } : sub { "" }; if (!ok $$thawn eq $$obj && &$newver($$thawn) eq &$newver($$obj), "get the right value back" ) { diag "$$thawn vs $$obj"; diag &$newver($$thawn) eq &$newver($$obj) if &$newver(1); } } else { is_deeply($thawn, $obj, "get the right value back"); } } } { # [perl #118551] { package RT118551; sub new { my $class = shift; my $string = shift; die 'Bad data' unless defined $string; my $self = { string => $string }; return bless $self, $class; } sub STORABLE_freeze { my $self = shift; my $cloning = shift; return if $cloning; return ($self->{string}); } sub STORABLE_attach { my $class = shift; my $cloning = shift; my $string = shift; return $class->new($string); } } my $x = [ RT118551->new('a'), RT118551->new('') ]; $y = freeze($x); ok(eval {thaw($y)}, "empty serialized") or diag $@; # <-- dies here with "Bad data" } { { package FreezeHookDies; sub STORABLE_freeze { die ${$_[0]} } package ThawHookDies; sub STORABLE_freeze { my ($self, $cloning) = @_; my $tmp = $$self; return "a", \$tmp; } sub STORABLE_thaw { my ($self, $cloning, $str, $obj) = @_; die $$obj; } } my $x = bless \(my $tmpx = "Foo"), "FreezeHookDies"; my $y = bless \(my $tmpy = []), "FreezeHookDies"; ok(!eval { store($x, "store$$"); 1 }, "store of hook which throws no NL died"); ok(!eval { store($y, "store$$"); 1 }, "store of hook which throws ref died"); ok(!eval { freeze($x); 1 }, "freeze of hook which throws no NL died"); ok(!eval { freeze($y); 1 }, "freeze of hook which throws ref died"); ok(!eval { dclone($x); 1 }, "dclone of hook which throws no NL died"); ok(!eval { dclone($y); 1 }, "dclone of hook which throws ref died"); my $ostr = bless \(my $tmpstr = "Foo"), "ThawHookDies"; my $oref = bless \(my $tmpref = []), "ThawHookDies"; ok(store($ostr, "store$$"), "save throw Foo on thaw"); ok(!eval { retrieve("store$$"); 1 }, "retrieve of throw Foo on thaw died"); open FH, "<", "store$$" or die; binmode FH; ok(!eval { fd_retrieve(FH); 1 }, "fd_retrieve of throw Foo on thaw died"); ok(!ref $@, "right thing thrown"); close FH; ok(store($oref, "store$$"), "save throw ref on thaw"); ok(!eval { retrieve("store$$"); 1 }, "retrieve of throw ref on thaw died"); open FH, "<", "store$$" or die; binmode FH; ok(!eval { fd_retrieve(FH); 1 }, "fd_retrieve of throw [] on thaw died"); ok(ref $@, "right thing thrown"); close FH; my $strdata = freeze($ostr); ok(!eval { thaw($strdata); 1 }, "thaw of throw Foo on thaw died"); ok(!ref $@, "and a string thrown"); my $refdata = freeze($oref); ok(!eval { thaw($refdata); 1 }, "thaw of throw [] on thaw died"); ok(ref $@, "and a ref thrown"); unlink("store$$"); } ��compat06.t��0000644��00000006377�15125143264�0006402 0��ustar�00��#!./perl # # Copyright (c) 1995-2000, Raphael Manfredi # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use Test::More tests => 8; use Storable qw(freeze nfreeze thaw); package TIED_HASH; sub TIEHASH { my $self = bless {}, shift; return $self; } sub FETCH { my $self = shift; my ($key) = @_; $main::hash_fetch++; return $self->{$key}; } sub STORE { my $self = shift; my ($key, $val) = @_; $self->{$key} = $val; } package SIMPLE; sub make { my $self = bless [], shift; my ($x) = @_; $self->[0] = $x; return $self; } package ROOT; sub make { my $self = bless {}, shift; my $h = tie %hash, TIED_HASH; $self->{h} = $h; $self->{ref} = \%hash; my @pool; for (my $i = 0; $i < 5; $i++) { push(@pool, SIMPLE->make($i)); } $self->{obj} = \@pool; my @a = ('string', $h, $self); $self->{a} = \@a; $self->{num} = [1, 0, -3, -3.14159, 456, 4.5]; $h->{key1} = 'val1'; $h->{key2} = 'val2'; return $self; }; sub num { $_[0]->{num} } sub h { $_[0]->{h} } sub ref { $_[0]->{ref} } sub obj { $_[0]->{obj} } package main; my $is_EBCDIC = (ord('A') == 193) ? 1 : 0; my $r = ROOT->make; my $data = ''; if (!$is_EBCDIC) { # ASCII machine while (<DATA>) { next if /^#/; $data .= unpack("u", $_); } } else { while (<DATA>) { next if /^#$/; # skip comments next if /^#\s+/; # skip comments next if /^[^#]/; # skip uuencoding for ASCII machines s/^#//; # prepare uuencoded data for EBCDIC machines $data .= unpack("u", $_); } } my $expected_length = $is_EBCDIC ? 217 : 278; is(length $data, $expected_length); my $y = thaw($data); isnt($y, undef); is(ref $y, 'ROOT'); $Storable::canonical = 1; # Prevent "used once" warning $Storable::canonical = 1; # Allow for long double string conversions. $y->{num}->[3] += 0; $r->{num}->[3] += 0; is(nfreeze($y), nfreeze($r)); is($y->ref->{key1}, 'val1'); is($y->ref->{key2}, 'val2'); is($hash_fetch, 2); my $num = $r->num; my $ok = 1; for (my $i = 0; $i < @$num; $i++) { do { $ok = 0; last } unless $num->[$i] == $y->num->[$i]; } is($ok, 1); __END__ # # using Storable-0.6@11, output of: print pack("u", nfreeze(ROOT->make)); # original size: 278 bytes # M`P,````%!`(````&"(%8"(!8"'U8"@@M,RXQ-#$U.5@)```!R%@`S0N-5A8 M6`````-N=6T$`P````(!'9A;#%8````!&ME>3$!'9A;#)8````!&ME>3)B M"51)141?2$%32%A8`````6@$`@````,!G-T<FEN9U@$``````I8!``````` M6%A8`````6$$`@````4$`@````$(@%AB!E-)35!,15A8!`(````!"(%88@93 M24U03$586`0"`````0B"6&(&4TE-4$Q%6%@$`@````$(@UAB!E-)35!,15A8 M!`(````!"(188@9324U03$586%A8`````V]B:@0,!``````6%A8`````W)E (9F($4D]/5%@` # # using Storable-0.6@11, output of: print '#' . pack("u", nfreeze(ROOT->make)); # on OS/390 (cp 1047) original size: 217 bytes # #M!0,1!-G6UN,#````!00,!!$)X\G%Q&W(P>+(`P````(!6!D_$````$DH6H #M\0H$I8&3\@````22A:CR`````YF%A@0"````!@B!"(`(?0H(8/-+\?3Q]?D) #M```!R`H#]$OU`````Y6DE`0"````!001!N+)U-?3Q0(````!"(`$$@("```` #M`0B!!!("`@````$(@@02`@(````!"(,$$@("`````0B$`````Y:"D00````` #E!`````&(!`(````#"@:BHYF)E8<$``````0$```````````!@0`` ��robust.t��0000644��00000000465�15125143264�0006257 0��ustar�00��#!/usr/bin/perl # This test script checks that Storable will load properly if someone # is incorrectly messing with %INC to hide Log::Agent. No, no-one should # really be doing this, but, then, it used* to work! use Test::More; plan tests => 1; $INC{'Log/Agent.pm'} = '#ignore#'; require Storable; pass; ��weak.t��0000644��00000007345�15125143264�0005674 0��ustar�00��#!./perl -w # # Copyright 2004, Larry Wall. # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # sub BEGIN { # This lets us distribute Test::More in t/ unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } if ($Config{extensions} !~ /\bList\/Util\b/) { print "1..0 # Skip: List::Util was not built\n"; exit 0; } require Scalar::Util; Scalar::Util->import(qw(weaken isweak)); if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) { print("1..0 # Skip: No support for weaken in Scalar::Util\n"); exit 0; } } use Test::More 'no_plan'; use Storable qw (store retrieve freeze thaw nstore nfreeze dclone); require 'testlib.pl'; our $file; use strict; # $Storable::flags = Storable::FLAGS_COMPAT; sub tester { my ($contents, $sub, $testersub, $what) = @_; # Test that if we re-write it, everything still works: my $clone = &$sub ($contents); is ($@, "", "There should be no error extracting for $what"); &$testersub ($clone, $what); } my $r = {}; my $s1 = [$r, $r]; weaken $s1->[1]; ok (isweak($s1->[1]), "element 1 is a weak reference"); my $s0 = [$r, $r]; weaken $s0->[0]; ok (isweak($s0->[0]), "element 0 is a weak reference"); my $w = [$r]; weaken $w->[0]; ok (isweak($w->[0]), "element 0 is a weak reference"); package OVERLOADED; use overload '""' => sub { $_[0][0] }; package main; $a = bless [77], 'OVERLOADED'; my $o = [$a, $a]; weaken $o->[0]; ok (isweak($o->[0]), "element 0 is a weak reference"); my @tests = ( [$s1, sub { my ($clone, $what) = @_; isa_ok($clone,'ARRAY'); isa_ok($clone->[0],'HASH'); isa_ok($clone->[1],'HASH'); ok(!isweak $clone->[0], "Element 0 isn't weak"); ok(isweak $clone->[1], "Element 1 is weak"); } ], # The weak reference needs to hang around long enough for other stuff to # be able to make references to it. So try it second. [$s0, sub { my ($clone, $what) = @_; isa_ok($clone,'ARRAY'); isa_ok($clone->[0],'HASH'); isa_ok($clone->[1],'HASH'); ok(isweak $clone->[0], "Element 0 is weak"); ok(!isweak $clone->[1], "Element 1 isn't weak"); } ], [$w, sub { my ($clone, $what) = @_; isa_ok($clone,'ARRAY'); if ($what eq 'nothing') { # We're the original, so we're still a weakref to a hash isa_ok($clone->[0],'HASH'); ok(isweak $clone->[0], "Element 0 is weak"); } else { is($clone->[0],undef); } } ], [$o, sub { my ($clone, $what) = @_; isa_ok($clone,'ARRAY'); isa_ok($clone->[0],'OVERLOADED'); isa_ok($clone->[1],'OVERLOADED'); ok(isweak $clone->[0], "Element 0 is weak"); ok(!isweak $clone->[1], "Element 1 isn't weak"); is ("$clone->[0]", 77, "Element 0 stringifies to 77"); is ("$clone->[1]", 77, "Element 1 stringifies to 77"); } ], ); foreach (@tests) { my ($input, $testsub) = @$_; tester($input, sub {return shift}, $testsub, 'nothing'); ok (defined store($input, $file)); # Read the contents into memory: my $contents = slurp ($file); tester($contents, \&store_and_retrieve, $testsub, 'file'); # And now try almost everything again with a Storable string my $stored = freeze $input; tester($stored, \&freeze_and_thaw, $testsub, 'string'); ok (defined nstore($input, $file)); tester($contents, \&store_and_retrieve, $testsub, 'network file'); $stored = nfreeze $input; tester($stored, \&freeze_and_thaw, $testsub, 'network string'); } { # [perl #134179] sv_upgrade from type 7 down to type 1 my $foo = [qr//,[]]; weaken($foo->[1][0][0] = $foo->[1]); my $out = dclone($foo); # croaked here is_deeply($out, $foo, "check they match"); } ��downgrade.t��0000644��00000037417�15125143264�0006722 0��ustar�00��#!./perl -w # # Copyright 2002, Larry Wall. # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # # I ought to keep this test easily backwards compatible to 5.004, so no # qr//; # This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features # are encountered. sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use Test::More; use Storable 'thaw'; use strict; our (%U_HASH, $UTF8_CROAK, $RESTRICTED_CROAK); our @RESTRICT_TESTS = ('Locked hash', 'Locked hash placeholder', 'Locked keys', 'Locked keys placeholder', ); our %R_HASH = (perl => 'rules'); if ($] > 5.007002) { # This is cheating. "\xdf" in Latin 1 is beta S, so will match \w if it # is stored in utf8, not bytes. # "\xdf" is y diaresis in EBCDIC (except for cp875, but so far no-one seems # to use that) which has exactly the same properties for \w # So the tests happen to pass. my $utf8 = "Schlo\xdf" . chr 256; chop $utf8; # \xe5 is V in EBCDIC. That doesn't have the same properties w.r.t. \w as # an a circumflex, so we need to be explicit. # and its these very properties we're trying to test - an edge case # involving whether scalars are being stored in bytes or in utf8. my $a_circumflex = (ord ('A') == 193 ? "\x47" : "\xe5"); %U_HASH = (map {$_, $_} 'castle', "ch${a_circumflex}teau", $utf8, chr 0x57CE); plan tests => 169; } else { plan tests => 59; } $UTF8_CROAK = "/^Cannot retrieve UTF8 data in non-UTF8 perl/"; $RESTRICTED_CROAK = "/^Cannot retrieve restricted hash/"; my %tests; { local $/ = "\n\nend\n"; while (<DATA>) { next unless /\S/s; unless (/begin ([0-7]{3}) ([^\n])\n(.)$/s) { s/\n.//s; warn "Dodgy data in section starting '$_'"; next; } next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa my $data = unpack 'u', $3; $tests{$2} = $data; } } # use Data::Dumper; $Data::Dumper::Useqq = 1; print Dumper \%tests; sub thaw_hash { my ($name, $expected) = @_; my $hash = eval {thaw $tests{$name}}; is ($@, '', "Thawed $name without error?"); isa_ok ($hash, 'HASH'); ok (defined $hash && eq_hash($hash, $expected), "And it is the hash we expected?"); $hash; } sub thaw_scalar { my ($name, $expected, $bug) = @_; my $scalar = eval {thaw $tests{$name}}; is ($@, '', "Thawed $name without error?"); isa_ok ($scalar, 'SCALAR', "Thawed $name?"); is ($$scalar, $expected, "And it is the data we expected?"); $scalar; } sub thaw_fail { my ($name, $expected) = @_; my $thing = eval {thaw $tests{$name}}; is ($thing, undef, "Thawed $name failed as expected?"); like ($@, $expected, "Error as predicted?"); } sub test_locked_hash { my $hash = shift; my @keys = keys %$hash; my ($key, $value) = each %$hash; eval {$hash->{$key} = reverse $value}; like( $@, "/^Modification of a read-only value attempted/", 'trying to change a locked key' ); is ($hash->{$key}, $value, "hash should not change?"); eval {$hash->{use} = 'perl'}; like( $@, "/^Attempt to access disallowed key 'use' in a restricted hash/", 'trying to add another key' ); ok (eq_array([keys %$hash], \@keys), "Still the same keys?"); } sub test_restricted_hash { my $hash = shift; my @keys = keys %$hash; my ($key, $value) = each %$hash; eval {$hash->{$key} = reverse $value}; is( $@, '', 'trying to change a restricted key' ); is ($hash->{$key}, reverse ($value), "hash should change"); eval {$hash->{use} = 'perl'}; like( $@, "/^Attempt to access disallowed key 'use' in a restricted hash/", 'trying to add another key' ); ok (eq_array([keys %$hash], \@keys), "Still the same keys?"); } sub test_placeholder { my $hash = shift; eval {$hash->{rules} = 42}; is ($@, '', 'No errors'); is ($hash->{rules}, 42, "New value added"); } sub test_newkey { my $hash = shift; eval {$hash->{nms} = "http://nms-cgi.sourceforge.net/"}; is ($@, '', 'No errors'); is ($hash->{nms}, "http://nms-cgi.sourceforge.net/", "New value added"); } # $Storable::DEBUGME = 1; thaw_hash ('Hash with utf8 flag but no utf8 keys', \%R_HASH); if (eval "use Hash::Util; 1") { print "# We have Hash::Util, so test that the restricted hashes in <DATA> are valid\n"; for $Storable::downgrade_restricted (0, 1, undef, "cheese") { my $hash = thaw_hash ('Locked hash', \%R_HASH); test_locked_hash ($hash); $hash = thaw_hash ('Locked hash placeholder', \%R_HASH); test_locked_hash ($hash); test_placeholder ($hash); $hash = thaw_hash ('Locked keys', \%R_HASH); test_restricted_hash ($hash); $hash = thaw_hash ('Locked keys placeholder', \%R_HASH); test_restricted_hash ($hash); test_placeholder ($hash); } } else { print "# We don't have Hash::Util, so test that the restricted hashes downgrade\n"; my $hash = thaw_hash ('Locked hash', \%R_HASH); test_newkey ($hash); $hash = thaw_hash ('Locked hash placeholder', \%R_HASH); test_newkey ($hash); $hash = thaw_hash ('Locked keys', \%R_HASH); test_newkey ($hash); $hash = thaw_hash ('Locked keys placeholder', \%R_HASH); test_newkey ($hash); local $Storable::downgrade_restricted = 0; thaw_fail ('Locked hash', $RESTRICTED_CROAK); thaw_fail ('Locked hash placeholder', $RESTRICTED_CROAK); thaw_fail ('Locked keys', $RESTRICTED_CROAK); thaw_fail ('Locked keys placeholder', $RESTRICTED_CROAK); } print "# We have utf8 scalars, so test that the utf8 scalars in <DATA> are valid\n"; thaw_scalar ('Short 8 bit utf8 data', "\xDF", 1); thaw_scalar ('Long 8 bit utf8 data', "\xDF" x 256, 1); thaw_scalar ('Short 24 bit utf8 data', chr 0xC0FFEE); thaw_scalar ('Long 24 bit utf8 data', chr (0xC0FFEE) x 256); if ($] > 5.007002) { print "# We have utf8 hashes, so test that the utf8 hashes in <DATA> are valid\n"; my $hash = thaw_hash ('Hash with utf8 keys', \%U_HASH); my $a_circumflex = (ord ('A') == 193 ? "\x47" : "\xe5"); for (keys %$hash) { my $l = 0 + /^\w+$/; my $r = 0 + $hash->{$_} =~ /^\w+$/; cmp_ok ($l, '==', $r, sprintf "key length %d", length $_); cmp_ok ($l, '==', $_ eq "ch${a_circumflex}teau" ? 0 : 1); } if (eval "use Hash::Util; 1") { print "# We have Hash::Util, so test that the restricted utf8 hash is valid\n"; my $hash = thaw_hash ('Locked hash with utf8 keys', \%U_HASH); for (keys %$hash) { my $l = 0 + /^\w+$/; my $r = 0 + $hash->{$_} =~ /^\w+$/; cmp_ok ($l, '==', $r, sprintf "key length %d", length $_); cmp_ok ($l, '==', $_ eq "ch${a_circumflex}teau" ? 0 : 1); } test_locked_hash ($hash); } else { print "# We don't have Hash::Util, so test that the utf8 hash downgrades\n"; fail ("You can't get here [perl version $]]. This is a bug in the test. # Please send the output of perl -V to perlbug\@perl.org"); } } else { print "# We don't have utf8 hashes, so test that the utf8 hashes downgrade\n"; thaw_fail ('Hash with utf8 keys', $UTF8_CROAK); thaw_fail ('Locked hash with utf8 keys', $UTF8_CROAK); local $Storable::drop_utf8 = 1; my $expect = thaw $tests{"Hash with utf8 keys for 5.6"}; thaw_hash ('Hash with utf8 keys', $expect); #foreach (keys %$expect) { print "'$_':\t'$expect->{$_}'\n"; } #foreach (keys %$got) { print "'$_':\t'$got->{$_}'\n"; } if (eval "use Hash::Util; 1") { print "# We have Hash::Util, so test that the restricted hashes in <DATA> are valid\n"; fail ("You can't get here [perl version $]]. This is a bug in the test. # Please send the output of perl -V to perlbug\@perl.org"); } else { print "# We don't have Hash::Util, so test that the restricted hashes downgrade\n"; my $hash = thaw_hash ('Locked hash with utf8 keys', $expect); test_newkey ($hash); local $Storable::downgrade_restricted = 0; thaw_fail ('Locked hash with utf8 keys', $RESTRICTED_CROAK); # Which croak comes first is a bit of an implementation issue :-) local $Storable::drop_utf8 = 0; thaw_fail ('Locked hash with utf8 keys', $RESTRICTED_CROAK); } } __END__ # A whole run of 2.x nfreeze data, uuencoded. The "mode bits" are the octal # value of 'A', the "file name" is the test name. Use make_downgrade.pl to # generate these. begin 101 Locked hash 8!049`0````$!7)U;&5S!`````1P97)L end begin 101 Locked hash placeholder C!049`0````(!7)U;&5S!`````1P97)L#A0````%<G5L97,` end begin 101 Locked keys 8!049`0````$!7)U;&5S``````1P97)L end begin 101 Locked keys placeholder C!049`0````(!7)U;&5S``````1P97)L#A0````%<G5L97,` end begin 101 Short 8 bit utf8 data &!047`L.? end begin 101 Short 8 bit utf8 data as bytes &!04`L.? end begin 101 Long 8 bit utf8 data M!048```"`,.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_# MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_# MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_# MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_# MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? MPY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_# MG\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? 8PY_#G\.?PY_#G\.?PY_#G\.?PY_#G\.? end begin 101 Short 24 bit utf8 data )!047!?BPC[^N end begin 101 Short 24 bit utf8 data as bytes )!04!?BPC[^N end begin 101 Long 24 bit utf8 data M!048```%`/BPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ MOZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N^+"/ ;OZ[XL(^_KOBPC[^N^+"/OZ[XL(^_KOBPC[^N end begin 101 Hash with utf8 flag but no utf8 keys 8!049``````$!7)U;&5S``````1P97)L end begin 101 Hash with utf8 keys M!049``````0!F-A<W1L90`````&8V%S=&QE"@=C:.5T96%U``````=C:.5T D96%U%P/EGXX!`````^6?CA<'4V-H;&_#GP(````&4V-H;&_? end begin 101 Locked hash with utf8 keys M!049`0````0!F-A<W1L900````&8V%S=&QE"@=C:.5T96%U!`````=C:.5T D96%U%P/EGXX%`````^6?CA<'4V-H;&_#GP8````&4V-H;&_? end begin 101 Hash with utf8 keys for 5.6 M!049``````0!F-A<W1L90`````&8V%S=&QE"@=C:.5T96%U``````=C:.5T D96%U%P/EGXX``````^6?CA<'4V-H;&_#GP(````&4V-H;&_? end begin 301 Locked hash 8!049`0````$!9FDDX6B!`````27A9F3 end begin 301 Locked hash placeholder C!049`0````(.%`````69I).%H@H%F:23A:($````!)>%F9,` end begin 301 Locked keys 8!049`0````$!9FDDX6B``````27A9F3 end begin 301 Locked keys placeholder C!049`0````(.%`````69I).%H@H%F:23A:(`````!)>%F9,` end begin 301 Short 8 bit utf8 data &!047`HMS end begin 301 Short 8 bit utf8 data as bytes &!04`HMS end begin 301 Long 8 bit utf8 data M!048```"`(MSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS MBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+ M<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS MBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+ M<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS MBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+ M<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS MBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+ M<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS MBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+ M<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS 8BW.+<XMSBW.+<XMSBW.+<XMSBW.+<XMS end begin 301 Short 24 bit utf8 data !047!OM30G-S50`` end begin 301 Short 24 bit utf8 data as bytes !04!OM30G-S50`` end begin 301 Long 24 bit utf8 data M!048```&`/M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S M5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M3 M0G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S5?M30G-S -5?M30G-S5?M30G-S50`` end begin 301 Hash with utf8 flag but no utf8 keys 8!049``````$!9FDDX6B``````27A9F3 end begin 301 Hash with utf8 keys M!049``````0!X.(1Z.%@:0`````!X.(1Z.%@:0!H.!HJ.3A0`````&@X&B FHY.%%P3<9')5`0````3<9')5%P?B@XB3EHMS`@````;B@XB3EM\` end begin 301 Locked hash with utf8 keys M!049`0````0!X.(1Z.%@:0$````!X.(1Z.%@:0!H.!HJ.3A00````&@X&B FHY.%%P3<9')5!0````3<9')5%P?B@XB3EHMS!@````;B@XB3EM\` end begin 301 Hash with utf8 keys for 5.6 M!049``````0!H.!HJ.3A0`````&@X&BHY.%"@>#B$>CA8&D``````>#B$>C FA8&D%P?B@XB3EHMS`@````;B@XB3EM\7!-QD<E4`````!-QD<E4` end ��HAS_HOOK.pm��0000644��00000000122�15125143264�0006333 0��ustar�00��package HAS_HOOK; sub STORABLE_thaw { ++$thawed_count; } ++$loaded_count; 1; ��attach_errors.t��0000644��00000015223�15125143264�0007577 0��ustar�00��#!./perl -w # # Copyright 2005, Adam Kennedy. # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # # Man, blessed.t scared the hell out of me. For a second there I thought # I'd lose Test::More... # This file tests several known-error cases relating to STORABLE_attach, in # which Storable should (correctly) throw errors. sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use Test::More tests => 40; use Storable (); ##################################################################### # Error 1 # # Classes that implement STORABLE_thaw _cannot_ have references # returned by their STORABLE_freeze method. When they do, Storable # should throw an exception # Good Case - should not die { my $goodfreeze = bless {}, 'My::GoodFreeze'; my $frozen = undef; eval { $frozen = Storable::freeze( $goodfreeze ); }; ok( ! $@, 'Storable does not die when STORABLE_freeze does not return references' ); ok( $frozen, 'Storable freezes to a string successfully' ); package My::GoodFreeze; sub STORABLE_freeze { my ($self, $clone) = @_; # Illegally include a reference in this return return (''); } sub STORABLE_attach { my ($class, $clone, $string) = @_; return bless { }, 'My::GoodFreeze'; } } # Error Case - should die on freeze { my $badfreeze = bless {}, 'My::BadFreeze'; eval { Storable::freeze( $badfreeze ); }; ok( $@, 'Storable dies correctly when STORABLE_freeze returns a reference' ); # Check for a unique substring of the error message ok( $@ =~ /cannot return references/, 'Storable dies with the expected error' ); package My::BadFreeze; sub STORABLE_freeze { my ($self, $clone) = @_; # Illegally include a reference in this return return ('', []); } sub STORABLE_attach { my ($class, $clone, $string) = @_; return bless { }, 'My::BadFreeze'; } } ##################################################################### # Error 2 # # If, for some reason, a STORABLE_attach object is accidentally stored # with references, this should be checked and an error should be thrown. # Good Case - should not die { my $goodthaw = bless {}, 'My::GoodThaw'; my $frozen = undef; eval { $frozen = Storable::freeze( $goodthaw ); }; ok( $frozen, 'Storable freezes to a string as expected' ); my $thawed = eval { Storable::thaw( $frozen ); }; isa_ok( $thawed, 'My::GoodThaw' ); is( $thawed->{foo}, 'bar', 'My::GoodThaw thawed correctly as expected' ); package My::GoodThaw; sub STORABLE_freeze { my ($self, $clone) = @_; return (''); } sub STORABLE_attach { my ($class, $clone, $string) = @_; return bless { 'foo' => 'bar' }, 'My::GoodThaw'; } } # Bad Case - should die on thaw { # Create the frozen string normally my $badthaw = bless { }, 'My::BadThaw'; my $frozen = undef; eval { $frozen = Storable::freeze( $badthaw ); }; ok( $frozen, 'BadThaw was frozen with references correctly' ); # Set up the error condition by deleting the normal STORABLE_thaw, # and creating a STORABLE_attach. My::BadThaw::STORABLE_attach = My::BadThaw::STORABLE_thaw; My::BadThaw::STORABLE_attach = My::BadThaw::STORABLE_thaw; # Suppress a warning delete ${'My::BadThaw::'}{STORABLE_thaw}; # Trigger the error condition my $thawed = undef; eval { $thawed = Storable::thaw( $frozen ); }; ok( $@, 'My::BadThaw object dies when thawing as expected' ); # Check for a snippet from the error message ok( $@ =~ /unexpected references/, 'Dies with the expected error message' ); package My::BadThaw; sub STORABLE_freeze { my ($self, $clone) = @_; return ('', []); } # Start with no STORABLE_attach method so we can get a # frozen object-containing-a-reference into the freeze string. sub STORABLE_thaw { my ($class, $clone, $string) = @_; return bless { 'foo' => 'bar' }, 'My::BadThaw'; } } ##################################################################### # Error 3 # # Die if what is returned by STORABLE_attach is not something of that class # Good Case - should not die { my $goodattach = bless { }, 'My::GoodAttach'; my $frozen = Storable::freeze( $goodattach ); ok( $frozen, 'My::GoodAttach return as expected' ); my $thawed = eval { Storable::thaw( $frozen ); }; isa_ok( $thawed, 'My::GoodAttach' ); is( ref($thawed), 'My::GoodAttach::Subclass', 'The slightly-tricky good "returns a subclass" case returns as expected' ); package My::GoodAttach; sub STORABLE_freeze { my ($self, $cloning) = @_; return (''); } sub STORABLE_attach { my ($class, $cloning, $string) = @_; return bless { }, 'My::GoodAttach::Subclass'; } package My::GoodAttach::Subclass; BEGIN { @ISA = 'My::GoodAttach'; } } # Good case - multiple references to the same object should be attached properly { my $obj = bless { id => 111 }, 'My::GoodAttach::MultipleReferences'; my $arr = [$obj]; push @$arr, $obj; my $frozen = Storable::freeze($arr); ok( $frozen, 'My::GoodAttach return as expected' ); my $thawed = eval { Storable::thaw( $frozen ); }; isa_ok( $thawed->[0], 'My::GoodAttach::MultipleReferences' ); isa_ok( $thawed->[1], 'My::GoodAttach::MultipleReferences' ); is($thawed->[0], $thawed->[1], 'References to the same object are attached properly'); is($thawed->[1]{id}, $obj->{id}, 'Object with multiple references attached properly'); package My::GoodAttach::MultipleReferences; sub STORABLE_freeze { my ($obj) = @_; $obj->{id} } sub STORABLE_attach { my ($class, $cloning, $id) = @_; bless { id => $id }, $class; } } # Bad Cases - die on thaw { my $returnvalue = undef; # Create and freeze the object my $badattach = bless { }, 'My::BadAttach'; my $frozen = Storable::freeze( $badattach ); ok( $frozen, 'BadAttach freezes as expected' ); # Try a number of different return values, all of which # should cause Storable to die. my @badthings = ( undef, '', 1, [], {}, \"foo", (bless { }, 'Foo'), ); foreach ( @badthings ) { $returnvalue = $_; my $thawed = undef; eval { $thawed = Storable::thaw( $frozen ); }; ok( $@, 'BadAttach dies on thaw' ); ok( $@ =~ /STORABLE_attach did not return a My::BadAttach object/, 'BadAttach dies on thaw with the expected error message' ); is( $thawed, undef, 'Double checking $thawed was not set' ); } package My::BadAttach; sub STORABLE_freeze { my ($self, $cloning) = @_; return (''); } sub STORABLE_attach { my ($class, $cloning, $string) = @_; return $returnvalue; } } ��flags.t��0000644��00000004506�15125143264�0006035 0��ustar�00��#!./perl use Test::More tests => 16; use Storable (); use warnings; use strict; package TEST; sub make { my $pkg = shift; return bless { a => 1, b => 2 }, $pkg; } package TIED_HASH; sub TIEHASH { my $pkg = shift; return bless { a => 1, b => 2 }, $pkg; } sub FETCH { my ($self, $key) = @_; return $self->{$key}; } sub STORE { my ($self, $key, $value) = @_; $self->{$key} = $value; } sub FIRSTKEY { my $self = shift; keys %$self; return each %$self; } sub NEXTKEY { my $self = shift; return each %{$self}; } sub EXISTS { my ($self, $key) = @_; return exists $self->{$key}; } package main; { my $obj = TEST->make; is_deeply($obj, { a => 1, b => 2 }, "object contains correct data"); my $frozen = Storable::freeze($obj); my ($t1, $t2) = Storable::thaw($frozen); { no warnings 'once'; local $Storable::flags = Storable::FLAGS_COMPAT(); $t2 = Storable::thaw($frozen); } is_deeply($t1, $t2, "objects contain matching data"); is(ref $t1, 'TEST', "default object is blessed"); is(ref $t2, 'TEST', "compat object is blessed into correct class"); my $t3 = Storable::thaw($frozen, Storable::FLAGS_COMPAT()); is_deeply($t2, $t3, "objects contain matching data (explicit test)"); is(ref $t3, 'TEST', "compat object is blessed into correct class (explicit test)"); my $t4 = Storable::thaw($frozen, Storable::BLESS_OK()); is_deeply($t2, $t3, "objects contain matching data (explicit test for bless)"); is(ref $t3, 'TEST', "compat object is blessed into correct class (explicit test for bless)"); { no warnings 'once'; local $Storable::flags = Storable::FLAGS_COMPAT(); my $t5 = Storable::thaw($frozen, 0); my $t6 = Storable::thaw($frozen, Storable::TIE_OK()); is_deeply($t1, $t5, "objects contain matching data"); is_deeply($t1, $t6, "objects contain matching data for TIE_OK"); is(ref $t5, 'HASH', "default object is unblessed"); is(ref $t6, 'HASH', "TIE_OK object is unblessed"); } } { tie my %hash, 'TIED_HASH'; ok(tied %hash, "hash is tied"); my $obj = { bow => \%hash }; my $frozen = Storable::freeze($obj); my $t1 = Storable::thaw($frozen, Storable::FLAGS_COMPAT()); my $t2 = eval { Storable::thaw($frozen); }; ok(!$@, "trying to thaw a tied value succeeds"); ok(tied %{$t1->{bow}}, "compat object is tied"); is(ref tied %{$t1->{bow}}, 'TIED_HASH', "compat object is tied into correct class"); } ��overload.t��0000644��00000004124�15125143264�0006550 0��ustar�00��#!./perl # # Copyright (c) 1995-2000, Raphael Manfredi # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use Storable qw(freeze thaw); $Storable::flags = Storable::FLAGS_COMPAT; use Test::More tests => 19; package OVERLOADED; use overload '""' => sub { $_[0][0] }; package main; $a = bless [77], OVERLOADED; $b = thaw freeze $a; is(ref $b, 'OVERLOADED'); is("$b", "77"); $c = thaw freeze \$a; is(ref $c, 'REF'); is(ref $$c, 'OVERLOADED'); is("$$c", "77"); $d = thaw freeze [$a, $a]; is("$d->[0]", "77"); $d->[0][0]++; is("$d->[1]", "78"); package REF_TO_OVER; sub make { my $self = bless {}, shift; my ($over) = @_; $self->{over} = $over; return $self; } package OVER; use overload '+' => \&plus, '""' => sub { ref $_[0] }; sub plus { return 314; } sub make { my $self = bless {}, shift; my $ref = REF_TO_OVER->make($self); $self->{ref} = $ref; return $self; } package main; $a = OVER->make(); $b = thaw freeze $a; is(ref $b, 'OVER'); is($a + $a, 314); is(ref $b->{ref}, 'REF_TO_OVER'); is("$b->{ref}->{over}", "$b"); is($b + $b, 314); # nfreeze data generated by make_overload.pl my $f = ''; if (ord ('A') == 193) { # EBCDIC. $f = unpack 'u', q{7!084$0S(P>)MUN7%V=/6P<0!*5EJ8`}; }else { $f = unpack 'u', q{7!084$0Q(05-?3U9%4DQ/040!'-N;W<`}; } # see note at the end of do_retrieve in Storable.xs about why this test has to # use a reference to an overloaded reference, rather than just a reference. my $t = eval {thaw $f}; print "# $@" if $@; is($@, ""); is(ref ($t), 'REF'); is(ref ($$t), 'HAS_OVERLOAD'); is($$$t, 'snow'); #--- # blessed reference to overloaded object. { my $a = bless [88], 'OVERLOADED'; my $c = thaw freeze bless \$a, 'main'; is(ref $c, 'main'); is(ref $$c, 'OVERLOADED'); is("$$c", "88"); } 1; ��make_downgrade.pl��0000644��00000004133�15125143264�0010054 0��ustar�00��#!/usr/local/bin/perl -w use strict; use 5.007003; use Hash::Util qw(lock_hash unlock_hash lock_keys); use Storable qw(nfreeze); # If this looks like a hack, it's probably because it is :-) sub uuencode_it { my ($data, $name) = @_; my $frozen = nfreeze $data; my $uu = pack 'u', $frozen; printf "begin %3o $name\n", ord 'A'; print $uu; print "\nend\n\n"; } my %hash = (perl=>"rules"); lock_hash %hash; uuencode_it (\%hash, "Locked hash"); unlock_hash %hash; lock_keys %hash, 'perl', 'rules'; lock_hash %hash; uuencode_it (\%hash, "Locked hash placeholder"); unlock_hash %hash; lock_keys %hash, 'perl'; uuencode_it (\%hash, "Locked keys"); unlock_hash %hash; lock_keys %hash, 'perl', 'rules'; uuencode_it (\%hash, "Locked keys placeholder"); unlock_hash %hash; my $utf8 = "\x{DF}\x{100}"; chop $utf8; uuencode_it (\$utf8, "Short 8 bit utf8 data"); my $utf8b = $utf8; utf8::encode ($utf8b); uuencode_it (\$utf8b, "Short 8 bit utf8 data as bytes"); $utf8 x= 256; uuencode_it (\$utf8, "Long 8 bit utf8 data"); $utf8 = "\x{C0FFEE}"; uuencode_it (\$utf8, "Short 24 bit utf8 data"); $utf8b = $utf8; utf8::encode ($utf8b); uuencode_it (\$utf8b, "Short 24 bit utf8 data as bytes"); $utf8 x= 256; uuencode_it (\$utf8, "Long 24 bit utf8 data"); # Hash which has the utf8 bit set, but no longer has any utf8 keys my %uhash = ("\x{100}", "gone", "perl", "rules"); delete $uhash{"\x{100}"}; # use Devel::Peek; Dump \%uhash; uuencode_it (\%uhash, "Hash with utf8 flag but no utf8 keys"); $utf8 = "Schlo\xdf" . chr 256; chop $utf8; my $a_circumflex = (ord ('A') == 193 ? "\x47" : "\xe5"); %uhash = (map {$_, $_} 'castle', "ch${a_circumflex}teau", $utf8, "\x{57CE}"); uuencode_it (\%uhash, "Hash with utf8 keys"); lock_hash %uhash; uuencode_it (\%uhash, "Locked hash with utf8 keys"); my %pre58; while (my ($key, $val) = each %uhash) { # hash keys are always stored downgraded to bytes if possible, with a flag # to say "promote back to utf8" # Whereas scalars are stored as is. utf8::encode ($key) if ord $key > 256; $pre58{$key} = $val; } uuencode_it (\%pre58, "Hash with utf8 keys for 5.6"); ��tied_store.t��0000644��00000001634�15125143264�0007101 0��ustar�00��#!./perl sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use Storable (); use Test::More tests => 3; our $f; package TIED_HASH; sub TIEHASH { bless({}, $_[0]) } sub STORE { $f = Storable::freeze(\$_[2]); 1; } package TIED_ARRAY; sub TIEARRAY { bless({}, $_[0]) } sub STORE { $f = Storable::freeze(\$_[2]); 1; } package TIED_SCALAR; sub TIESCALAR { bless({}, $_[0]) } sub STORE { $f = Storable::freeze(\$_[1]); 1; } package main; my($s, @a, %h); tie $s, "TIED_SCALAR"; tie @a, "TIED_ARRAY"; tie %h, "TIED_HASH"; $f = undef; $s = 111; is $f, Storable::freeze(\111); $f = undef; $a[3] = 222; is $f, Storable::freeze(\222); $f = undef; $h{foo} = 333; is $f, Storable::freeze(\333); 1; ��HAS_ATTACH.pm��0000644��00000000171�15125143264�0006543 0��ustar�00��package HAS_ATTACH; sub STORABLE_attach { ++$attached_count; return bless [], 'HAS_ATTACH'; } ++$loaded_count; 1; ��croak.t��0000644��00000001665�15125143264�0006043 0��ustar�00��#!./perl -w # Please keep this test this simple. (ie just one test.) # There's some sort of not-croaking properly problem in Storable when built # with 5.005_03. This test shows it up, whereas malice.t does not. # In particular, don't use Test; as this covers up the problem. sub BEGIN { if ($ENV{PERL_CORE}) { require Config; import Config; %Config=%Config if 0; # cease -w if ($Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } } use strict; BEGIN { die "Oi! No! Don't change this test so that Carp is used before Storable" if defined &Carp::carp; } use Storable qw(freeze thaw); print "1..2\n"; for my $test (1,2) { eval {thaw "\xFF\xFF"}; if ($@ =~ /Storable binary image v127.255 more recent than I am \(v2\.\d+\)/) { print "ok $test\n"; } else { chomp $@; print "not ok $test # Expected a meaningful croak. Got '$@'\n"; } } ��tied_hook.t��0000644��00000011205�15125143264�0006700 0��ustar�00��#!./perl # # Copyright (c) 1995-2000, Raphael Manfredi # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } require 'st-dump.pl'; } use Storable qw(freeze thaw); $Storable::flags = Storable::FLAGS_COMPAT; use Test::More tests => 28; ($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0); package TIED_HASH; sub TIEHASH { my $self = bless {}, shift; return $self; } sub FETCH { my $self = shift; my ($key) = @_; $main::hash_fetch++; return $self->{$key}; } sub STORE { my $self = shift; my ($key, $value) = @_; $self->{$key} = $value; } sub FIRSTKEY { my $self = shift; scalar keys %{$self}; return each %{$self}; } sub NEXTKEY { my $self = shift; return each %{$self}; } sub STORABLE_freeze { my $self = shift; $main::hash_hook1++; return join(":", keys %$self) . ";" . join(":", values %$self); } sub STORABLE_thaw { my ($self, $cloning, $frozen) = @_; my ($keys, $values) = split(/;/, $frozen); my @keys = split(/:/, $keys); my @values = split(/:/, $values); for (my $i = 0; $i < @keys; $i++) { $self->{$keys[$i]} = $values[$i]; } $main::hash_hook2++; } package TIED_ARRAY; sub TIEARRAY { my $self = bless [], shift; return $self; } sub FETCH { my $self = shift; my ($idx) = @_; $main::array_fetch++; return $self->[$idx]; } sub STORE { my $self = shift; my ($idx, $value) = @_; $self->[$idx] = $value; } sub FETCHSIZE { my $self = shift; return @{$self}; } sub STORABLE_freeze { my $self = shift; $main::array_hook1++; return join(":", @$self); } sub STORABLE_thaw { my ($self, $cloning, $frozen) = @_; @$self = split(/:/, $frozen); $main::array_hook2++; } package TIED_SCALAR; sub TIESCALAR { my $scalar; my $self = bless \$scalar, shift; return $self; } sub FETCH { my $self = shift; $main::scalar_fetch++; return $$self; } sub STORE { my $self = shift; my ($value) = @_; $$self = $value; } sub STORABLE_freeze { my $self = shift; $main::scalar_hook1++; return $$self; } sub STORABLE_thaw { my ($self, $cloning, $frozen) = @_; $$self = $frozen; $main::scalar_hook2++; } package main; $a = 'toto'; $b = \$a; $c = tie %hash, TIED_HASH; $d = tie @array, TIED_ARRAY; tie $scalar, TIED_SCALAR; $scalar = 'foo'; $hash{'attribute'} = 'plain value'; $array[0] = \$scalar; $array[1] = $c; $array[2] = \@array; $array[3] = "plaine scalaire"; @tied = (\$scalar, \@array, \%hash); %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$a, 'scalarref', \$scalar); @a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d, $b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied); my $f = freeze(\@a); isnt($f, undef); $dumped = &dump(\@a); isnt($dumped, undef); $root = thaw($f); isnt($root, undef); $got = &dump($root); isnt($got, undef); isnt($got, $dumped); # our hooks did not handle refs in array $g = freeze($root); is(length $f, length $g); # Ensure the tied items in the retrieved image work @old = ($scalar_fetch, $array_fetch, $hash_fetch); @tied = ($tscalar, $tarray, $thash) = @{$root->[$#{$root}]}; @type = qw(SCALAR ARRAY HASH); is(ref tied $$tscalar, 'TIED_SCALAR'); is(ref tied @$tarray, 'TIED_ARRAY'); is(ref tied %$thash, 'TIED_HASH'); @new = ($$tscalar, $tarray->[0], $thash->{'attribute'}); @new = ($scalar_fetch, $array_fetch, $hash_fetch); # Tests 10..15 for ($i = 0; $i < @new; $i++) { is($new[$i], $old[$i] + 1); # Tests 10,12,14 is(ref $tied[$i], $type[$i]); # Tests 11,13,15 } is($$tscalar, 'foo'); is($tarray->[3], 'plaine scalaire'); is($thash->{'attribute'}, 'plain value'); # Ensure hooks were called is($scalar_hook1, 2); is($scalar_hook2, 1); is($array_hook1, 2); is($array_hook2, 1); is($hash_hook1, 2); is($hash_hook2, 1); # # And now for the "blessed ref to tied hash" with "store hook" test... # my $bc = bless \%hash, 'FOO'; # FOO does not exist -> no hook my $bx = thaw freeze $bc; is(ref $bx, 'FOO'); my $old_hash_fetch = $hash_fetch; my $v = $bx->{attribute}; is($hash_fetch, $old_hash_fetch + 1, 'Still tied'); package TIED_HASH_REF; sub STORABLE_freeze { my ($self, $cloning) = @_; return if $cloning; return('ref lost'); } sub STORABLE_thaw { my ($self, $cloning, $data) = @_; return if $cloning; } package main; $bc = bless \%hash, 'TIED_HASH_REF'; $bx = thaw freeze $bc; is(ref $bx, 'TIED_HASH_REF'); $old_hash_fetch = $hash_fetch; $v = $bx->{attribute}; is($hash_fetch, $old_hash_fetch + 1, 'Still tied'); ��HAS_OVERLOAD.pm��0000644��00000000271�15125143264�0007013 0��ustar�00��package HAS_OVERLOAD; use overload '""' => sub { ${$_[0]} }, fallback => 1; sub make { my $package = shift; my $value = shift; bless \$value, $package; } ++$loaded_count; 1; ��lock.t��0000644��00000002011�15125143264�0005656 0��ustar�00��#!./perl # # Copyright (c) 1995-2000, Raphael Manfredi # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } require 'st-dump.pl'; } use Test::More; use Storable qw(lock_store lock_retrieve); unless (&Storable::CAN_FLOCK) { plan(skip_all => "fcntl/flock emulation broken on this platform"); } plan(tests => 5); @a = ('first', undef, 3, -4, -3.14159, 456, 4.5); # # We're just ensuring things work, we're not validating locking. # isnt(lock_store(\@a, "store$$"), undef); my $dumped = &dump(\@a); isnt($dumped, undef); $root = lock_retrieve("store$$"); is(ref $root, 'ARRAY'); is(scalar @a, scalar @$root); is(&dump($root), $dumped); END { 1 while unlink "store$$" } ��restrict.t��0000644��00000006772�15125143264�0006607 0��ustar�00��#!./perl -w # # Copyright 2002, Larry Wall. # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; if ($ENV{PERL_CORE}){ require Config; if ($Config::Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } else { if (!eval "require Hash::Util") { if ($@ =~ /Can\'t locate Hash\/Util\.pm in \@INC/s) { print "1..0 # Skip: No Hash::Util:\n"; exit 0; } else { die; } } unshift @INC, 't'; } } use Storable qw(dclone freeze thaw); use Hash::Util qw(lock_hash unlock_value lock_keys); use Config; $Storable::DEBUGME = $ENV{STORABLE_DEBUGME}; use Test::More tests => (!$Storable::DEBUGME && $Config{usecperl} ? 105 : 304); my %hash = (question => '?', answer => 42, extra => 'junk', undef => undef); lock_hash %hash; unlock_value %hash, 'answer'; unlock_value %hash, 'extra'; delete $hash{'extra'}; my $test; package Restrict_Test; sub me_second { return (undef, $_[0]); } package main; sub freeze_thaw { my $temp = freeze $_[0]; return thaw $temp; } sub testit { my $hash = shift; my $cloner = shift; my $copy = &$cloner($hash); my @in_keys = sort keys %$hash; my @out_keys = sort keys %$copy; is("@in_keys", "@out_keys", "keys match after deep clone"); # $copy = $hash; # used in initial debug of the tests is(Internals::SvREADONLY(%$copy), 1, "cloned hash restricted?"); is(Internals::SvREADONLY($copy->{question}), 1, "key 'question' not locked in copy?"); is(Internals::SvREADONLY($copy->{answer}), '', "key 'answer' not locked in copy?"); eval { $copy->{extra} = 15 } ; is($@, '', "Can assign to reserved key 'extra'?"); eval { $copy->{nono} = 7 } ; isnt($@, '', "Can not assign to invalid key 'nono'?"); is(exists $copy->{undef}, 1, "key 'undef' exists"); is($copy->{undef}, undef, "value for key 'undef' is undefined"); } for $Storable::canonical (0, 1) { for my $cloner (\&dclone, \&freeze_thaw) { print "# \$Storable::canonical = $Storable::canonical\n"; testit (\%hash, $cloner); my $object = \%hash; # bless {}, "Restrict_Test"; my %hash2; $hash2{"k$_"} = "v$_" for 0..16; lock_hash %hash2; for (0..16) { unlock_value %hash2, "k$_"; delete $hash2{"k$_"}; } my $copy = &$cloner(\%hash2); for (0..16) { my $k = "k$_"; eval { $copy->{$k} = undef } ; is($@, '', "Can assign to reserved key '$k'?"); } my %hv; $hv{a} = __PACKAGE__; lock_keys %hv; my $hv2 = &$cloner(\%hv); ok eval { $$hv2{a} = 70 }, 'COWs do not become read-only'; } } # [perl #73972] # broken again with cperl PERL_PERTURB_KEYS_TOP. SKIP: { skip "TODO restricted Storable hashes broken with PERL_PERTURB_KEYS_TOP", 1 if !$Storable::DEBUGME && $Config{usecperl}; for my $n (1..100) { my @keys = map { "FOO$_" } (1..$n); my $hash1 = {}; lock_keys(%$hash1, @keys); my $hash2 = dclone($hash1); my $success; $success = eval { $hash2->{$_} = 'test' for @keys; 1 }; my $err = $@; ok($success, "can store in all of the $n restricted slots") \|\| diag("failed with $@"); $success = !eval { $hash2->{a} = 'test'; 1 }; ok($success, "the hash is still restricted"); } } ��attach_singleton.t��0000644��00000004777�15125143264�0010301 0��ustar�00��#!./perl -w # # Copyright 2005, Adam Kennedy. # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # # Tests freezing/thawing structures containing Singleton objects, # which should see both structs pointing to the same object. sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use Test::More tests => 16; use Storable (); # Get the singleton my $object = My::Singleton->new; isa_ok( $object, 'My::Singleton' ); # Confirm (for the record) that the class is actually a Singleton my $object2 = My::Singleton->new; isa_ok( $object2, 'My::Singleton' ); is( "$object", "$object2", 'Class is a singleton' ); ############ # Main Tests my $struct = [ 1, $object, 3 ]; # Freeze the struct my $frozen = Storable::freeze( $struct ); ok( (defined($frozen) and ! ref($frozen) and length($frozen)), 'freeze returns a string' ); # Thaw the struct my $thawed = Storable::thaw( $frozen ); # Now it should look exactly like the original is_deeply( $struct, $thawed, 'Struct superficially looks like the original' ); # ... EXCEPT that the Singleton should be the same instance of the object is( "$struct->[1]", "$thawed->[1]", 'Singleton thaws correctly' ); # We can also test this empirically $struct->[1]->{value} = 'Goodbye cruel world!'; is_deeply( $struct, $thawed, 'Empiric testing confirms correct behaviour' ); $struct = [ $object, $object ]; $frozen = Storable::freeze($struct); $thawed = Storable::thaw($frozen); is("$thawed->[0]", "$thawed->[1]", "Multiple Singletons thaw correctly"); # End Tests ########### package My::Singleton; my $SINGLETON = undef; sub new { $SINGLETON or $SINGLETON = bless { value => 'Hello World!' }, $_[0]; } sub STORABLE_freeze { my $self = shift; # We don't actually need to return anything, but provide a null string # to avoid the null-list-return behaviour. return ('foo'); } sub STORABLE_attach { my ($class, $clone, $string) = @_; Test::More::ok( ! ref $class, 'STORABLE_attach passed class, and not an object' ); Test::More::is( $class, 'My::Singleton', 'STORABLE_attach is passed the correct class name' ); Test::More::is( $clone, 0, 'We are not in a dclone' ); Test::More::is( $string, 'foo', 'STORABLE_attach gets the string back' ); # Get the Singleton object and return it return $class->new; } �CVE-2015-1592.t��0000644��00000001026�15125143264�0006333 0��ustar�00��#!/usr/bin/perl use strict; use warnings; use Test::More; use Storable qw(freeze thaw); plan tests => 1; # this original worked with the packaged exploit, but that # triggers virus scanners, so test for the behaviour instead my $x = bless \(my $y = "mt-config.cgi"), "CGITempFile"; my $frozen = freeze($x); { my $warnings = ''; local $SIG{__WARN__} = sub { $warnings .= "@_" }; thaw($frozen); like($warnings, qr/SECURITY: Movable-Type CVE-2015-1592 Storable metasploit attack/, 'Detect CVE-2015-1592'); } ��file_magic.t��0000644��00000032351�15125143264�0007017 0��ustar�00��#!perl -w BEGIN { unshift @INC, 't/compat' if $] < 5.006002; }; use strict; use Test::More; use Storable qw(store nstore); use Config qw(%Config); # The @tests array below was create by the following program my $dummy = <<'EOT'; use Storable; use Data::Dump qw(dump); print "my \@tests = (\n"; for my $f (<data_>) { print " [\n"; print " " . dump(substr(`cat $f`, 0, 32) . "...") , ",\n"; my $x = dump(Storable::file_magic($f)); $x =~ s/^/ /gm; print "$x,\n"; print " ],\n"; } print ");\n"; EOT my @tests = ( [ "perl-store\x041234\4\4\4\xD4\xC2\32\b\3\13\0\0\0v\b\xC5\32\b...", { byteorder => 1234, file => "data_perl-5.006001_i686-linux-thread-multi_Storable-0.1.le32", hdrsize => 18, intsize => 4, longsize => 4, netorder => 0, ptrsize => 4, version => -1, version_nv => -1, }, ], [ "perl-store\0\x041234\4\4\4\x8Co\34\b\3\13\0\0\0v\x94v\34...", { byteorder => 1234, file => "data_perl-5.006001_i686-linux-thread-multi_Storable-0.4_07.le32", hdrsize => 19, intsize => 4, longsize => 4, major => 0, netorder => 0, ptrsize => 4, version => 0, version_nv => 0, }, ], [ "perl-store\1\x8Co\34\b\3\0\0\0\13v\x94v\34\b\1\0\0\4\0\0\0...", { file => "data_perl-5.006001_i686-linux-thread-multi_Storable-0.4_07.neutral", hdrsize => 11, major => 0, netorder => 1, version => 0, version_nv => 0, }, ], [ "pst0\2\x041234\4\4\4\3\13\0\0\0\1\0\4\0\0\0\0\0\0\0\0\0\0\0...", { byteorder => 1234, file => "data_perl-5.006001_i686-linux-thread-multi_Storable-0.604.le32", hdrsize => 13, intsize => 4, longsize => 4, major => 1, netorder => 0, ptrsize => 4, version => 1, version_nv => 1, }, ], [ "pst0\3\3\0\0\0\13\1\0\0\4\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0...", { file => "data_perl-5.006001_i686-linux-thread-multi_Storable-0.604.neutral", hdrsize => 5, major => 1, netorder => 1, version => 1, version_nv => 1, }, ], [ "pst0\4\0\x041234\4\4\4\3\13\0\0\0\1\0\4\0\0\0\0\0\0\0\0\0\0...", { byteorder => 1234, file => "data_perl-5.006001_i686-linux-thread-multi_Storable-0.700.le32", hdrsize => 14, intsize => 4, longsize => 4, major => 2, minor => 0, netorder => 0, ptrsize => 4, version => "2.0", version_nv => "2.000", }, ], [ "pst0\5\0\3\0\0\0\13\1\0\0\4\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0...", { file => "data_perl-5.006001_i686-linux-thread-multi_Storable-0.700.neutral", hdrsize => 6, major => 2, minor => 0, netorder => 1, version => "2.0", version_nv => "2.000", }, ], [ "pst0\4\4\x041234\4\4\4\x08\3\13\0\0\0\1\0\4\0\0\0\0\0\0\0\0\0...", { byteorder => 1234, file => "data_perl-5.006001_i686-linux-thread-multi_Storable-1.012.le32", hdrsize => 15, intsize => 4, longsize => 4, major => 2, minor => 4, netorder => 0, nvsize => 8, ptrsize => 4, version => "2.4", version_nv => "2.004", }, ], [ "pst0\4\3\x044321\4\4\4\x08\3\0\0\0\13\1\0\0\4\0\0\0\0\0\0\0\0...", { byteorder => 4321, file => "data_perl-5.006001_IA64.ARCHREV_0-thread-multi_Storable-1.006.be32", hdrsize => 15, intsize => 4, longsize => 4, major => 2, minor => 3, netorder => 0, nvsize => 8, ptrsize => 4, version => "2.3", version_nv => "2.003", }, ], [ "pst0\5\3\3\0\0\0\13\1\0\0\4\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0...", { file => "data_perl-5.006001_IA64.ARCHREV_0-thread-multi_Storable-1.006.neutral", hdrsize => 6, major => 2, minor => 3, netorder => 1, version => "2.3", version_nv => "2.003", }, ], [ "pst0\4\4\x044321\4\4\4\x08\3\0\0\0\13\1\0\0\4\0\0\0\0\0\0\0\0...", { byteorder => 4321, file => "data_perl-5.006001_IA64.ARCHREV_0-thread-multi_Storable-1.012.be32", hdrsize => 15, intsize => 4, longsize => 4, major => 2, minor => 4, netorder => 0, nvsize => 8, ptrsize => 4, version => "2.4", version_nv => "2.004", }, ], [ "pst0\5\4\3\0\0\0\13\1\0\0\4\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0...", { file => "data_perl-5.006001_IA64.ARCHREV_0-thread-multi_Storable-1.012.neutral", hdrsize => 6, major => 2, minor => 4, netorder => 1, version => "2.4", version_nv => "2.004", }, ], [ "pst0\4\6\x044321\4\4\4\x08\3\0\0\0\13\n\n4294967296...", { byteorder => 4321, file => "data_perl-5.008001_darwin-thread-multi-2level_Storable-2.08.be32", hdrsize => 15, intsize => 4, longsize => 4, major => 2, minor => 6, netorder => 0, nvsize => 8, ptrsize => 4, version => "2.6", version_nv => "2.006", }, ], [ "pst0\5\6\3\0\0\0\13\n\n4294967296\0\0\0\bfour_...", { file => "data_perl-5.008001_darwin-thread-multi-2level_Storable-2.08.neutral", hdrsize => 6, major => 2, minor => 6, netorder => 1, version => "2.6", version_nv => "2.006", }, ], [ "pst0\4\6\x044321\4\4\4\x08\3\0\0\0\13\4\3\0\0\0\0\0\0\0\nem...", { byteorder => 4321, file => "data_perl-5.008003_PA-RISC1.1-thread-multi_Storable-2.09.be32", hdrsize => 15, intsize => 4, longsize => 4, major => 2, minor => 6, netorder => 0, nvsize => 8, ptrsize => 4, version => "2.6", version_nv => "2.006", }, ], [ "pst0\5\6\3\0\0\0\13\4\3\0\0\0\0\0\0\0\nempty_hash\n...", { file => "data_perl-5.008003_PA-RISC1.1-thread-multi_Storable-2.09.neutral", hdrsize => 6, major => 2, minor => 6, netorder => 1, version => "2.6", version_nv => "2.006", }, ], [ "pst0\4\6\x0812345678\4\4\4\x08\3\13\0\0\0\4\3\0\0\0\0\n\0...", { byteorder => 12_345_678, file => "data_perl-5.008004_i86pc-solaris-64int_Storable-2.12.le64", hdrsize => 19, intsize => 4, longsize => 4, major => 2, minor => 6, netorder => 0, nvsize => 8, ptrsize => 4, version => "2.6", version_nv => "2.006", }, ], [ "pst0\4\6\x041234\4\4\4\x08\3\13\0\0\0\4\3\0\0\0\0\n\0\0\0em...", { byteorder => 1234, file => "data_perl-5.008006_i686-linux-thread-multi_Storable-2.13.le32", hdrsize => 15, intsize => 4, longsize => 4, major => 2, minor => 6, netorder => 0, nvsize => 8, ptrsize => 4, version => "2.6", version_nv => "2.006", }, ], [ "pst0\4\6\x0887654321\4\x08\x08\x08\3\0\0\0\13\4\3\0\0\0\0\0\0...", { byteorder => 87_654_321, file => "data_perl-5.008007_IA64.ARCHREV_0-thread-multi-LP64_Storable-2.13.be64", hdrsize => 19, intsize => 4, longsize => 8, major => 2, minor => 6, netorder => 0, nvsize => 8, ptrsize => 8, version => "2.6", version_nv => "2.006", }, ], [ "pst0\4\x07\x0812345678\4\x08\x08\x08\3\13\0\0\0\4\3\0\0\0\0\n\0...", { byteorder => 12_345_678, file => "data_perl-5.008007_x86-solaris-thread-multi-64_Storable-2.15.le64", hdrsize => 19, intsize => 4, longsize => 8, major => 2, minor => 7, netorder => 0, nvsize => 8, ptrsize => 8, version => "2.7", version_nv => "2.007", }, ], [ "pst0\5\x07\3\0\0\0\13\4\3\0\0\0\0\0\0\0\nempty_hash\n...", { file => "data_perl-5.008007_x86-solaris-thread-multi-64_Storable-2.15.neutral", hdrsize => 6, major => 2, minor => 7, netorder => 1, version => "2.7", version_nv => "2.007", }, ], [ "pst0\4\5\x041234\4\4\4\x08\3\13\0\0\0\4\3\0\0\0\0\n\0\0\0em...", { byteorder => 1234, file => "data_perl-5.008_i686-linux-thread-multi_Storable-2.04.le32", hdrsize => 15, intsize => 4, longsize => 4, major => 2, minor => 5, netorder => 0, nvsize => 8, ptrsize => 4, version => "2.5", version_nv => "2.005", }, ], [ "pst0\5\5\3\0\0\0\13\4\3\0\0\0\0\0\0\0\nempty_hash\n...", { file => "data_perl-5.008_i686-linux-thread-multi_Storable-2.04.neutral", hdrsize => 6, major => 2, minor => 5, netorder => 1, version => "2.5", version_nv => "2.005", }, ], [ "pst0\4\x07\x041234\4\4\4\x08\3\13\0\0\0\4\3\0\0\0\0\n\0\0\0em...", { byteorder => 1234, file => "data_perl-5.009003_i686-linux_Storable-2.15.le32", hdrsize => 15, intsize => 4, longsize => 4, major => 2, minor => 7, netorder => 0, nvsize => 8, ptrsize => 4, version => "2.7", version_nv => "2.007", }, ], ); plan tests => 31 + 2 @tests; my $file = "xx-$$.pst"; is(eval { Storable::file_magic($file) }, undef, "empty file give undef"); like($@, qq{/^Can't open '\Q$file\E':/}, "...and croaks"); is(Storable::file_magic(__FILE__), undef, "not an image"); store({}, $file); { my $info = Storable::file_magic($file); unlink($file); ok($info, "got info"); is($info->{file}, $file, "file set"); is($info->{hdrsize}, 11 + length($Config{byteorder}), "hdrsize"); like($info->{version}, q{/^2\.\d+$/}, "sane version"); is($info->{version_nv}, Storable::BIN_WRITE_VERSION_NV, "version_nv match"); is($info->{major}, 2, "sane major"); ok($info->{minor}, "have minor"); ok($info->{minor} >= Storable::BIN_WRITE_MINOR, "large enough minor"); ok(!$info->{netorder}, "no netorder"); my %attrs = ( nvsize => 5.006, ptrsize => 5.005, map {$_ => 5.004} qw(byteorder intsize longsize) ); for my $attr (keys %attrs) { SKIP: { skip "attribute $attr not available on this version of Perl", 1 if $attrs{$attr} > $]; is($info->{$attr}, $Config{$attr}, "$attr match Config"); } } } nstore({}, $file); { my $info = Storable::file_magic($file); unlink($file); ok($info, "got info"); is($info->{file}, $file, "file set"); is($info->{hdrsize}, 6, "hdrsize"); like($info->{version}, q{/^2\.\d+$/}, "sane version"); is($info->{version_nv}, Storable::BIN_WRITE_VERSION_NV, "version_nv match"); is($info->{major}, 2, "sane major"); ok($info->{minor}, "have minor"); ok($info->{minor} >= Storable::BIN_WRITE_MINOR, "large enough minor"); ok($info->{netorder}, "no netorder"); for (qw(byteorder intsize longsize ptrsize nvsize)) { ok(!exists $info->{$_}, "no $_"); } } for my $test (@tests) { my($data, $expected) = @$test; open(FH, '>', $file) \|\| die "Can't create $file: $!"; binmode(FH); print FH $data; close(FH) \|\| die "Can't write $file: $!"; my $name = $expected->{file}; $expected->{file} = $file; my $info = Storable::file_magic($file); unlink($file); is_deeply($info, $expected, "file_magic $name"); $expected->{file} = 1; is_deeply(Storable::read_magic($data), $expected, "read magic $name"); } ��freeze.t��0000644��00000005070�15125143264�0006216 0��ustar�00��#!./perl # # Copyright (c) 1995-2000, Raphael Manfredi # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } require 'st-dump.pl'; } use Storable qw(freeze nfreeze thaw); $Storable::flags = Storable::FLAGS_COMPAT; use Test::More tests => 21; $a = 'toto'; $b = \$a; $c = bless {}, CLASS; $c->{attribute} = $b; $d = {}; $e = []; $d->{'a'} = $e; $e->[0] = $d; %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); @a = ('first', undef, 3, -4, -3.14159, 456, 4.5, $d, \$d, \$e, $e, $b, \$a, $a, $c, \$c, \%a); my $f1 = freeze(\@a); isnt($f1, undef); $dumped = &dump(\@a); isnt($dumped, undef); $root = thaw($f1); isnt($root, undef); $got = &dump($root); isnt($got, undef); is($got, $dumped); package FOO; @ISA = qw(Storable); sub make { my $self = bless {}; $self->{key} = \%main::a; return $self; }; package main; $foo = FOO->make; my $f2 = $foo->freeze; isnt($f2, undef); my $f3 = $foo->nfreeze; isnt($f3, undef); $root3 = thaw($f3); isnt($root3, undef); is(&dump($foo), &dump($root3)); $root = thaw($f2); is(&dump($foo), &dump($root)); is(&dump($root3), &dump($root)); $other = freeze($root); is(length$other, length $f2); $root2 = thaw($other); is(&dump($root2), &dump($root)); $VAR1 = [ 'method', 1, 'prepare', 'SELECT table_name, table_owner, num_rows FROM iitables where table_owner != \'$ingres\' and table_owner != \'DBA\'' ]; $x = nfreeze($VAR1); $VAR2 = thaw($x); is($VAR2->[3], $VAR1->[3]); # Test the workaround for LVALUE bug in perl 5.004_04 -- from Gisle Aas sub foo { $_[0] = 1 } $foo = []; foo($foo->[1]); eval { freeze($foo) }; is($@, ''); # Test cleanup bug found by Claudio Garcia -- RAM, 08/06/2001 my $thaw_me = 'asdasdasdasd'; eval { my $thawed = thaw $thaw_me; }; isnt($@, ''); my %to_be_frozen = (foo => 'bar'); my $frozen; eval { $frozen = freeze \%to_be_frozen; }; is($@, ''); freeze {}; eval { thaw $thaw_me }; eval { $frozen = freeze { foo => {} } }; is($@, ''); thaw $frozen; # used to segfault here pass("Didn't segfault"); SKIP: { my (@a, @b); eval ' $a = []; $#$a = 2; $a->[1] = undef; $b = thaw freeze $a; @a = map { ~~ exists $a->[$_] } 0 .. $#$a; @b = map { ~~ exists $b->[$_] } 0 .. $#$b; '; is($@, ''); is("@a", "@b"); } ��compat01.t��0000644��00000002231�15125143264�0006356 0��ustar�00��#!perl -w BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } use Config; if ($Config{byteorder} ne "1234") { print "1..0 # Skip: Test only works for 32 bit little-ending machines\n"; exit 0; } } use strict; use Storable qw(retrieve); use Test::More; my $file = "xx-$$.pst"; my @dumps = ( # some sample dumps of the hash { one => 1 } "perl-store\x041234\4\4\4\x94y\22\b\3\1\0\0\0vxz\22\b\1\1\0\0\x001Xk\3\0\0\0oneX", # 0.1 "perl-store\0\x041234\4\4\4\x94y\22\b\3\1\0\0\0vxz\22\b\b\x81Xk\3\0\0\0oneX", # 0.4@7 ); plan(tests => 3 * @dumps); my $testno; for my $dump (@dumps) { $testno++; open(FH, '>', $file) \|\| die "Can't create $file: $!"; binmode(FH); print FH $dump; close(FH) \|\| die "Can't write $file: $!"; my $data = eval { retrieve($file) }; is($@, '', "No errors for $file"); is(ref $data, 'HASH', "Got HASH for $file"); is($data->{one}, 1, "Got data for $file"); unlink($file); } ��st-dump.pl��0000644��00000006550�15125143264�0006503 0��ustar�00��# # Copyright (c) 1995-2000, Raphael Manfredi # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # package dump; use Carp; %dump = ( 'SCALAR' => 'dump_scalar', 'LVALUE' => 'dump_scalar', 'ARRAY' => 'dump_array', 'HASH' => 'dump_hash', 'REF' => 'dump_ref', ); # Given an object, dump its transitive data closure sub main::dump { my ($object) = @_; croak "Not a reference!" unless ref($object); local %dumped; local %object; local $count = 0; local $dumped = ''; &recursive_dump($object, 1); return $dumped; } # This is the root recursive dumping routine that may indirectly be # called by one of the routine it calls... # The link parameter is set to false when the reference passed to # the routine is an internal temporary variable, implying the object's # address is not to be dumped in the %dumped table since it's not a # user-visible object. sub recursive_dump { my ($object, $link) = @_; # Get something like SCALAR(0x...) or TYPE=SCALAR(0x...). # Then extract the bless, ref and address parts of that string. my $what = "$object"; # Stringify my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.)\)$/; ($ref, $addr) = $what =~ /^(\w+)\((0x.)\)$/ unless $bless; # Special case for references to references. When stringified, # they appear as being scalars. However, ref() correctly pinpoints # them as being references indirections. And that's it. $ref = 'REF' if ref($object) eq 'REF'; # Make sure the object has not been already dumped before. # We don't want to duplicate data. Retrieval will know how to # relink from the previously seen object. if ($link && $dumped{$addr}++) { my $num = $object{$addr}; $dumped .= "OBJECT #$num seen\n"; return; } my $objcount = $count++; $object{$addr} = $objcount; # Call the appropriate dumping routine based on the reference type. # If the referenced was blessed, we bless it once the object is dumped. # The retrieval code will perform the same on the last object retrieved. croak "Unknown simple type '$ref'" unless defined $dump{$ref}; &{$dump{$ref}}($object); # Dump object &bless($bless) if $bless; # Mark it as blessed, if necessary $dumped .= "OBJECT $objcount\n"; } # Indicate that current object is blessed sub bless { my ($class) = @_; $dumped .= "BLESS $class\n"; } # Dump single scalar sub dump_scalar { my ($sref) = @_; my $scalar = $$sref; unless (defined $scalar) { $dumped .= "UNDEF\n"; return; } my $len = length($scalar); $dumped .= "SCALAR len=$len $scalar\n"; } # Dump array sub dump_array { my ($aref) = @_; my $items = 0 + @{$aref}; $dumped .= "ARRAY items=$items\n"; foreach $item (@{$aref}) { unless (defined $item) { $dumped .= 'ITEM_UNDEF' . "\n"; next; } $dumped .= 'ITEM '; &recursive_dump(\$item, 1); } } # Dump hash table sub dump_hash { my ($href) = @_; my $items = scalar(keys %{$href}); $dumped .= "HASH items=$items\n"; foreach $key (sort keys %{$href}) { $dumped .= 'KEY '; &recursive_dump(\$key, undef); unless (defined $href->{$key}) { $dumped .= 'VALUE_UNDEF' . "\n"; next; } $dumped .= 'VALUE '; &recursive_dump(\$href->{$key}, 1); } } # Dump reference to reference sub dump_ref { my ($rref) = @_; my $deref = $$rref; # Follow reference to reference $dumped .= 'REF '; &recursive_dump($deref, 1); # $dref is a reference } 1; ��retrieve.t��0000644��00000006027�15125143264�0006566 0��ustar�00��#!./perl # # Copyright (c) 1995-2000, Raphael Manfredi # Copyright (c) 2017, cPanel Inc # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # sub BEGIN { unshift @INC, 'dist/Storable/t' if $ENV{PERL_CORE} and -d 'dist/Storable/t'; unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } require 'st-dump.pl'; } use Storable qw(store retrieve nstore); use Test::More tests => 20; $a = 'toto'; $b = \$a; $c = bless {}, CLASS; $c->{attribute} = 'attrval'; %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); @a = ('first', '', undef, 3, -4, -3.14159, 456, 4.5, $b, \$a, $a, $c, \$c, \%a); isnt(store(\@a, "store$$"), undef); is(Storable::last_op_in_netorder(), ''); isnt(nstore(\@a, 'nstore'), undef); is(Storable::last_op_in_netorder(), 1); is(Storable::last_op_in_netorder(), 1); $root = retrieve("store$$"); isnt($root, undef); is(Storable::last_op_in_netorder(), ''); $nroot = retrieve('nstore'); isnt($root, undef); is(Storable::last_op_in_netorder(), 1); $d1 = &dump($root); isnt($d1, undef); $d2 = &dump($nroot); isnt($d2, undef); is($d1, $d2); # Make sure empty string is defined at retrieval time isnt($root->[1], undef); is(length $root->[1], 0); # $Storable::DEBUGME = 1; { # len>I32: todo patch the storable image number into the strings, fake 2.10 # $Storable::BIN_MINOR my $retrieve_blessed = "\x04\x0a\x08\x31\x32\x33\x34\x35\x36\x37\x38\x04\x08\x08\x08\x11\xff\x49\x6e\x74\xff\x72\x6e\x61\x6c\x73\x02\x00\x00\x00\x00"; my $x = eval { Storable::mretrieve($retrieve_blessed); }; # Long integer or Double size or Byte order is not compatible like($@, qr/^(Corrupted classname length\|.* is not compatible\|panic: malloc)/, "RT #130635 $@"); is($x, undef, 'and undef result'); } { # len>I32 my $retrieve_hook = "\x04\x0a\x08\x31\x32\x33\x34\x35\x36\x37\x38\x04\x08\x08\x08\x13\x04\x49\xfe\xf4\xff\x72\x6e\x61\x6c\x73\x02\x00\x00\x00\x00"; my $x = eval { Storable::mretrieve($retrieve_hook); }; like($@, qr/^(Corrupted classname length\|.* is not compatible\|panic: malloc)/, "$@"); is($x, undef, 'and undef result'); } SKIP: { # this can allocate a lot of memory, only do that if the testers tells us we can # the test allocates 2GB, but other memory is allocated too, so we want # at least 3 $ENV{PERL_TEST_MEMORY} && $ENV{PERL_TEST_MEMORY} >= 3 or skip "over 2GB memory needed for this test", 2; # len<I32, len>127: stack overflow my $retrieve_hook = "\x04\x0a\x08\x31\x32\x33\x34\x35\x36\x37\x38\x04\x08\x08\x08\x13\x04\x49\xfe\xf4\x7f\x72\x6e\x61\x6c\x73\x02\x00\x00\x00\x00"; my $x = eval { Storable::mretrieve($retrieve_hook); }; is($?, 0, "no stack overflow in retrieve_hook()"); is($x, undef, 'either out of mem or normal error (malloc 2GB)'); } END { 1 while unlink("store$$", 'nstore') } ��utf8hash.t��0000644��00000012472�15125143264�0006474 0��ustar�00��#!./perl sub BEGIN { if ($] < 5.007) { print "1..0 # Skip: no utf8 hash key support\n"; exit 0; } unshift @INC, 't'; require Config; import Config; if ($ENV{PERL_CORE}){ if($Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } } use strict; our $DEBUGME = shift \|\| 0; use Storable qw(store nstore retrieve thaw freeze); { no warnings; $Storable::DEBUGME = ($DEBUGME > 1); } # Better than no plan, because I was getting out of memory errors, at which # point Test::More tidily prints up 1..79 as if I meant to finish there. use Test::More tests=>144; use bytes (); my %utf8hash; $Storable::flags = Storable::FLAGS_COMPAT; $Storable::canonical = $Storable::canonical; # Shut up a used only once warning. for $Storable::canonical (0, 1) { # first we generate a nasty hash which keys include both utf8 # on and off with identical PVs no utf8; # we have a naked 8-bit byte below (in Latin 1, anyway) # In Latin 1 -ese the below ord() should end up 0xc0 (192), # in EBCDIC 0x64 (100). Both should end up being UTF-8/UTF-EBCDIC. my @ords = ( ord("�"), # LATIN CAPITAL LETTER A WITH GRAVE 0x3000, #IDEOGRAPHIC SPACE ); foreach my $i (@ords){ my $u = chr($i); utf8::upgrade($u); # warn sprintf "%d,%d", bytes::length($u), is_utf8($u); my $b = chr($i); utf8::encode($b); # warn sprintf "%d,%d" ,bytes::length($b), is_utf8($b); isnt($u, $b, "equivalence - with utf8flag"); $utf8hash{$u} = $utf8hash{$b} = $i; } sub nkeys($){ my $href = shift; return scalar keys %$href; } my $nk; is($nk = nkeys(\%utf8hash), scalar(@ords)2, "nasty hash generated (nkeys=$nk)"); # now let the show begin! my $thawed = thaw(freeze(\%utf8hash)); is($nk = nkeys($thawed), nkeys(\%utf8hash), "scalar keys \%{\$thawed} (nkeys=$nk)"); for my $k (sort keys %$thawed){ is($utf8hash{$k}, $thawed->{$k}, "frozen item chr($utf8hash{$k})"); } my $storage = "utfhash.po"; # po = perl object! my $retrieved; ok((nstore \%utf8hash, $storage), "nstore to $storage"); ok(($retrieved = retrieve($storage)), "retrieve from $storage"); is($nk = nkeys($retrieved), nkeys(\%utf8hash), "scalar keys \%{\$retrieved} (nkeys=$nk)"); for my $k (sort keys %$retrieved){ is($utf8hash{$k}, $retrieved->{$k}, "nstored item chr($utf8hash{$k})"); } unlink $storage; ok((store \%utf8hash, $storage), "store to $storage"); ok(($retrieved = retrieve($storage)), "retrieve from $storage"); is($nk = nkeys($retrieved), nkeys(\%utf8hash), "scalar keys \%{\$retrieved} (nkeys=$nk)"); for my $k (sort keys %$retrieved){ is($utf8hash{$k}, $retrieved->{$k}, "stored item chr($utf8hash{$k})"); } $DEBUGME or unlink $storage; # On the premis that more tests are good, here are NWC's tests: package Hash_Test; sub me_second { return (undef, $_[0]); } package main; my $utf8 = "Schlo\xdf" . chr 256; chop $utf8; # Set this to 1 to test the test by bypassing Storable. my $bypass = 0; sub class_test { my ($object, $package) = @_; unless ($package) { is ref $object, 'HASH', "$object is unblessed"; return; } isa_ok ($object, $package); my ($garbage, $copy) = eval {$object->me_second}; is $@, "", "check it has correct method"; cmp_ok $copy, '==', $object, "and that it returns the same object"; } # Thanks to Dan Kogai for the Kanji for "castle" (which he informs me also # means 'a city' in Mandarin). my %hash = (map {$_, $_} 'castle', "ch\xe5teau", $utf8, "\x{57CE}"); for my $package ('', 'Hash_Test') { # Run through and sanity check these. if ($package) { bless \%hash, $package; } for (keys %hash) { my $l = 0 + /^\w+$/; my $r = 0 + $hash{$_} =~ /^\w+$/; cmp_ok ($l, '==', $r); } # Grr. This cperl mode thinks that ${ is a punctuation variable. # I presume it's punishment for using xemacs rather than emacs. Or OS/2 :-) my $copy = $bypass ? \%hash : ${thaw freeze \\%hash}; class_test ($copy, $package); for (keys %$copy) { my $l = 0 + /^\w+$/; my $r = 0 + $copy->{$_} =~ /^\w+$/; cmp_ok ($l, '==', $r, sprintf "key length %d", length $_); } my $bytes = my $char = chr 27182; utf8::encode ($bytes); my $orig = {$char => 1}; if ($package) { bless $orig, $package; } my $just_utf8 = $bypass ? $orig : ${thaw freeze \$orig}; class_test ($just_utf8, $package); cmp_ok (scalar keys %$just_utf8, '==', 1, "1 key in utf8?"); cmp_ok ($just_utf8->{$char}, '==', 1, "utf8 key present?"); ok (!exists $just_utf8->{$bytes}, "bytes key absent?"); $orig = {$bytes => 1}; if ($package) { bless $orig, $package; } my $just_bytes = $bypass ? $orig : ${thaw freeze \$orig}; class_test ($just_bytes, $package); cmp_ok (scalar keys %$just_bytes, '==', 1, "1 key in bytes?"); cmp_ok ($just_bytes->{$bytes}, '==', 1, "bytes key present?"); ok (!exists $just_bytes->{$char}, "utf8 key absent?"); die sprintf "Both have length %d, which is crazy", length $char if length $char == length $bytes; $orig = {$bytes => length $bytes, $char => length $char}; if ($package) { bless $orig, $package; } my $both = $bypass ? $orig : ${thaw freeze \$orig}; class_test ($both, $package); cmp_ok (scalar keys %$both, '==', 2, "2 keys?"); cmp_ok ($both->{$bytes}, '==', length $bytes, "bytes key present?"); cmp_ok ($both->{$char}, '==', length $char, "utf8 key present?"); } } ��code.t��0000644��00000016453�15125143264�0005657 0��ustar�00��#!./perl # # Copyright (c) 2002 Slaven Rezic # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use strict; BEGIN { if (!eval q{ use Test::More; use B::Deparse 0.61; use 5.006; 1; }) { print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n"; exit; } require File::Spec; if ($File::Spec::VERSION < 0.8) { print "1..0 # Skip: newer File::Spec needed\n"; exit 0; } } BEGIN { plan tests => 63 } use Storable qw(retrieve store nstore freeze nfreeze thaw dclone); use Safe; #$Storable::DEBUGME = 1; our ($freezed, $thawed, @obj, @res, $blessed_code); $blessed_code = bless sub { "blessed" }, "Some::Package"; { package Another::Package; sub foo { __PACKAGE__ } } { no strict; # to make the life for Safe->reval easier sub code { "JAPH" } } local FOO; @obj = ([\&code, # code reference sub { 67 }, $blessed_code, # blessed code reference \&Another::Package::foo, # code in another package sub ($$;$) { 0 }, # prototypes sub { print "test\n" }, \&Storable::_store, # large scalar ], {"a" => sub { "srt" }, "b" => \&code}, sub { ord("a")-ord("7") }, \&code, \&dclone, # XS function sub { open FOO, '<', "/" }, ); $Storable::Deparse = 1; $Storable::Eval = 1; ###################################################################### # Test freeze & thaw $freezed = freeze $obj[0]; $thawed = thaw $freezed; is($thawed->[0]->(), "JAPH"); is($thawed->[1]->(), 42); is($thawed->[2]->(), "blessed"); is($thawed->[3]->(), "Another::Package"); is(prototype($thawed->[4]), prototype($obj[0]->[4])); ###################################################################### $freezed = freeze $obj[1]; $thawed = thaw $freezed; is($thawed->{"a"}->(), "srt"); is($thawed->{"b"}->(), "JAPH"); ###################################################################### $freezed = freeze $obj[2]; $thawed = thaw $freezed; is($thawed->(), (ord "A") == 193 ? -118 : 42); ###################################################################### $freezed = freeze $obj[3]; $thawed = thaw $freezed; is($thawed->(), "JAPH"); ###################################################################### eval { $freezed = freeze $obj[4] }; like($@, qr/The result of B::Deparse::coderef2text was empty/); ###################################################################### # Test dclone my $new_sub = dclone($obj[2]); is($new_sub->(), $obj[2]->()); ###################################################################### # Test retrieve & store store $obj[0], "store$$"; # $Storable::DEBUGME = 1; $thawed = retrieve "store$$"; is($thawed->[0]->(), "JAPH"); is($thawed->[1]->(), 42); is($thawed->[2]->(), "blessed"); is($thawed->[3]->(), "Another::Package"); is(prototype($thawed->[4]), prototype($obj[0]->[4])); ###################################################################### nstore $obj[0], "store$$"; $thawed = retrieve "store$$"; unlink "store$$"; is($thawed->[0]->(), "JAPH"); is($thawed->[1]->(), 42); is($thawed->[2]->(), "blessed"); is($thawed->[3]->(), "Another::Package"); is(prototype($thawed->[4]), prototype($obj[0]->[4])); ###################################################################### # Security with # $Storable::Eval # $Storable::Deparse { local $Storable::Eval = 0; for my $i (0 .. 1) { $freezed = freeze $obj[$i]; $@ = ""; eval { $thawed = thaw $freezed }; like($@, qr/Can\'t eval/); } } { local $Storable::Deparse = 0; for my $i (0 .. 1) { $@ = ""; eval { $freezed = freeze $obj[$i] }; like($@, qr/Can\'t store CODE items/); } } { local $Storable::Eval = 0; local $Storable::forgive_me = 1; for my $i (0 .. 4) { $freezed = freeze $obj[0]->[$i]; $@ = ""; eval { $thawed = thaw $freezed }; is($@, ""); like($$thawed, qr/^sub/); } } { local $Storable::Deparse = 0; local $Storable::forgive_me = 1; my $devnull = File::Spec->devnull; open(SAVEERR, ">&STDERR"); open(STDERR, '>', $devnull) or ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); eval { $freezed = freeze $obj[0]->[0] }; open(STDERR, ">&SAVEERR"); is($@, ""); isnt($freezed, ''); } { my $safe = new Safe; local $Storable::Eval = sub { $safe->reval(shift) }; $freezed = freeze $obj[0]->[0]; $@ = ""; eval { $thawed = thaw $freezed }; is($@, ""); is($thawed->(), "JAPH"); $freezed = freeze $obj[0]->[6]; eval { $thawed = thaw $freezed }; # The "Code sub ..." error message only appears if Log::Agent is installed like($@, qr/(trapped\|Code sub)/); if (0) { # Disable or fix this test if the internal representation of Storable # changes. skip("no malicious storable file check", 1); } else { # Construct malicious storable code $freezed = nfreeze $obj[0]->[0]; my $bad_code = ';open FOO, "/badfile"'; # 5th byte is (short) length of scalar my $len = ord(substr($freezed, 4, 1)); substr($freezed, 4, 1, chr($len+length($bad_code))); substr($freezed, -1, 0, $bad_code); $@ = ""; eval { $thawed = thaw $freezed }; like($@, qr/(trapped\|Code sub)/); } } { my $safe = new Safe; # because of opcodes used in "use strict": $safe->permit(qw(:default require caller)); local $Storable::Eval = sub { $safe->reval(shift) }; $freezed = freeze $obj[0]->[1]; $@ = ""; eval { $thawed = thaw $freezed }; is($@, ""); is($thawed->(), 42); } { { package MySafe; sub new { bless {}, shift } sub reval { my $source = $_[1]; # Here you can apply some nifty regexpes to ensure the # safeness of the source code. my $coderef = eval $source; $coderef; } } my $safe = new MySafe; local $Storable::Eval = sub { $safe->reval($_[0]) }; $freezed = freeze $obj[0]; eval { $thawed = thaw $freezed }; is($@, ""); if ($@ ne "") { fail() for (1..5); } else { is($thawed->[0]->(), "JAPH"); is($thawed->[1]->(), 42); is($thawed->[2]->(), "blessed"); is($thawed->[3]->(), "Another::Package"); is(prototype($thawed->[4]), prototype($obj[0]->[4])); } } { # Check internal "seen" code my $short_sub = sub { "short sub" }; # for SX_SCALAR # for SX_LSCALAR my $long_sub_code = 'sub { "' . "x"x255 . '" }'; my $long_sub = eval $long_sub_code; die $@ if $@; my $sclr = \1; local $Storable::Deparse = 1; local $Storable::Eval = 1; for my $sub ($short_sub, $long_sub) { my $res; $res = thaw freeze [$sub, $sub]; is(int($res->[0]), int($res->[1])); $res = thaw freeze [$sclr, $sub, $sub, $sclr]; is(int($res->[0]), int($res->[3])); is(int($res->[1]), int($res->[2])); $res = thaw freeze [$sub, $sub, $sclr, $sclr]; is(int($res->[0]), int($res->[1])); is(int($res->[2]), int($res->[3])); } } { my @text = ("hello", "\x{a3}", "\x{a3} \x{2234}", "\x{2234}\x{2234}"); for my $text(@text) { my $res = (thaw freeze eval "sub {'" . $text . "'}")->(); ok($res eq $text); } } ��forgive.t��0000644��00000003025�15125143264�0006375 0��ustar�00��#!./perl # # Copyright (c) 1995-2000, Raphael Manfredi # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # # Original Author: Ulrich Pfeifer # (C) Copyright 1997, Universitat Dortmund, all rights reserved. # sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use Storable qw(store retrieve); use Test::More; # problems with 5.00404 when in an BEGIN block, so this is defined here if (!eval { require File::Spec; 1 } \|\| $File::Spec::VERSION < 0.8) { plan(skip_all => "File::Spec 0.8 needed"); # Mention $File::Spec::VERSION again, as 5.00503's harness seems to have # warnings on. exit $File::Spec::VERSION; } plan(tests => 8); GLOB = GLOB; # peacify -w my $bad = ['foo', \GLOB, 'bar']; my $result; eval {$result = store ($bad , "store$$")}; is($result, undef); isnt($@, ''); $Storable::forgive_me=1; my $devnull = File::Spec->devnull; open(SAVEERR, ">&STDERR"); open(STDERR, '>', $devnull) or ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) ); eval {$result = store ($bad , "store$$")}; open(STDERR, ">&SAVEERR"); isnt($result, undef); is($@, ''); my $ret = retrieve("store$$"); isnt($ret, undef); is($ret->[0], 'foo'); is($ret->[2], 'bar'); is(ref $ret->[1], 'SCALAR'); END { 1 while unlink "store$$" } ��store.t��0000644��00000006373�15125143264�0006101 0��ustar�00��#!./perl # # Copyright (c) 1995-2000, Raphael Manfredi # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } require 'st-dump.pl'; } # $Storable::DEBUGME = 1; use Storable qw(store retrieve store_fd nstore_fd fd_retrieve); use Test::More tests => 25; $a = 'toto'; $b = \$a; $c = bless {}, CLASS; $c->{attribute} = 'attrval'; %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); @a = ('first', undef, 3, -4, -3.14159, 456, 4.5, $b, \$a, $a, $c, \$c, \%a); isnt(store(\@a, "store$$"), undef); $dumped = &dump(\@a); isnt($dumped, undef); $root = retrieve("store$$"); isnt($root, undef); $got = &dump($root); isnt($got, undef); is($got, $dumped); 1 while unlink "store$$"; package FOO; @ISA = qw(Storable); sub make { my $self = bless {}; $self->{key} = \%main::a; return $self; }; package main; $foo = FOO->make; isnt($foo->store("store$$"), undef); isnt(open(OUT, '>>', "store$$"), undef); binmode OUT; isnt(store_fd(\@a, ::OUT), undef); isnt(nstore_fd($foo, ::OUT), undef); isnt(nstore_fd(\%a, ::OUT), undef); isnt(close(OUT), undef); isnt(open(OUT, "store$$"), undef); $r = fd_retrieve(::OUT); isnt($r, undef); is(&dump($r), &dump($foo)); $r = fd_retrieve(::OUT); isnt($r, undef); is(&dump($r), &dump(\@a)); $r = fd_retrieve(main::OUT); isnt($r, undef); is(&dump($r), &dump($foo)); $r = fd_retrieve(::OUT); isnt($r, undef); is(&dump($r), &dump(\%a)); eval { $r = fd_retrieve(::OUT); }; isnt($@, ''); { my %test = ( old_retrieve_array => "\x70\x73\x74\x30\x01\x0a\x02\x02\x02\x02\x00\x3d\x08\x84\x08\x85\x08\x06\x04\x00\x00\x01\x1b", old_retrieve_hash => "\x70\x73\x74\x30\x01\x0a\x03\x00\xe8\x03\x00\x00\x81\x00\x00\x00\x01\x61", retrieve_code => "\x70\x73\x74\x30\x05\x0a\x19\xf0\x00\xff\xe8\x03\x1a\x0a\x0e\x01", ); for my $k (sort keys %test) { open my $fh, '<', \$test{$k}; eval { Storable::fd_retrieve($fh); }; is($?, 0, 'RT 130098: no segfault in Storable::fd_retrieve()'); } } { my $frozen = "\x70\x73\x74\x30\x04\x0a\x08\x31\x32\x33\x34\x35\x36\x37\x38\x04\x08\x08\x08\x03\xff\x00\x00\x00\x19\x08\xff\x00\x00\x00\x08\x08\xf9\x16\x16\x13\x16\x10\x10\x10\xff\x15\x16\x16\x16\x1e\x16\x16\x16\x16\x16\x16\x16\x16\x16\x16\x13\xf0\x16\x16\x16\xfe\x16\x41\x41\x41\x41\xe8\x03\x41\x41\x41\x41\x41\x41\x41\x41\x51\x41\xa9\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xb8\xac\xac\xac\xac\xac\xac\xac\xac\x9a\xac\xac\xac\xac\xac\xac\xac\xac\xac\x93\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\x00\x64\xac\xa8\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\xac\x2c\xac\x41\x41\x41\x41\x41\x41\x41\x41\x41\x00\x80\x41\x80\x41\x41\x41\x41\x41\x41\x51\x41\xac\xac\xac"; open my $fh, '<', \$frozen; eval { Storable::fd_retrieve($fh); }; pass('RT 130635: no stack smashing error when retrieving hook'); } close OUT or die "Could not close: $!"; END { 1 while unlink "store$$" } ��leaks.t��0000644��00000001515�15125143264�0006035 0��ustar�00��#!./perl use Test::More; use Storable (); BEGIN { eval "use Test::LeakTrace"; plan 'skip_all' => 'Test::LeakTrace required for this tests' if $@; } plan 'tests' => 1; { my $c = My::Simple->new; my $d; my $freezed = Storable::freeze($c); no_leaks_ok { $d = Storable::thaw($freezed); undef $d; }; package My::Simple; sub new { my ($class, $arg) = @_; bless {t=>$arg}, $class; } sub STORABLE_freeze { return "abcderfgh"; } sub STORABLE_attach { my ($class, $c, $serialized) = @_; return $class->new($serialized); } } { # [cpan #97316] package TestClass; sub new { my $class = shift; return bless({}, $class); } sub STORABLE_freeze { die; } package main; my $obj = TestClass->new; eval { freeze($obj); }; } ��just_plain_nasty.t��0000644��00000010444�15125143264�0010325 0��ustar�00��#!/usr/bin/perl # This is a test suite to cover all the nasty and horrible data # structures that cause bizarre corner cases. # Everyone's invited! :-D sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use strict; BEGIN { if (!eval q{ use Test::More; use B::Deparse 0.61; use 5.006; 1; }) { print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n"; exit; } require File::Spec; if ($File::Spec::VERSION < 0.8) { print "1..0 # Skip: newer File::Spec needed\n"; exit 0; } } use Storable qw(freeze thaw); $Storable::flags = Storable::FLAGS_COMPAT; #$Storable::DEBUGME = 1; BEGIN { plan tests => 34; } { package Banana; use overload '<=>' => \&compare, '==' => \&equal, '""' => \&real, fallback => 1; sub compare { return int(rand(3))-1 }; sub equal { return 1 if rand(1) > 0.5 } sub real { return "keep it so" } } my (@a); for my $dbun (1, 0) { # dbun - don't be utterly nasty - being utterly # nasty means having a reference to the object # directly within itself. otherwise it's in the # second array. my $nasty = [ ($a[0] = bless [ ], "Banana"), ($a[1] = [ ]), ]; $a[$dbun]->[0] = $a[0]; is(ref($nasty), "ARRAY", "Sanity found (now to play with it :->)"); $Storable::Deparse = $Storable::Deparse = 1; $Storable::Eval = $Storable::Eval = 1; headit("circular overload 1 - freeze"); my $icicle = freeze $nasty; #print $icicle; # cat -ve recommended :) headit("circular overload 1 - thaw"); my $oh_dear = thaw $icicle; is(ref($oh_dear), "ARRAY", "dclone - circular overload"); is($oh_dear->[0], "keep it so", "amagic ok 1"); is($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2"); headit("closure dclone - freeze"); $icicle = freeze sub { "two" }; #print $icicle; headit("closure dclone - thaw"); my $sub2 = thaw $icicle; is($sub2->(), "two", "closures getting dcloned OK"); headit("circular overload, after closure - freeze"); #use Data::Dumper; #print Dumper $nasty; $icicle = freeze $nasty; #print $icicle; headit("circular overload, after closure - thaw"); $oh_dear = thaw $icicle; is(ref($oh_dear), "ARRAY", "dclone - after a closure dclone"); is($oh_dear->[0], "keep it so", "amagic ok 1"); is($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2"); push @{$nasty}, sub { print "Goodbye, cruel world.\n" }; headit("closure freeze AFTER circular overload"); #print Dumper $nasty; $icicle = freeze $nasty; #print $icicle; headit("circular thaw AFTER circular overload"); $oh_dear = thaw $icicle; is(ref($oh_dear), "ARRAY", "dclone - before a closure dclone"); is($oh_dear->[0], "keep it so", "amagic ok 1"); is($oh_dear->[$dbun]->[0], "keep it so", "amagic ok 2"); @{$nasty} = @{$nasty}[0, 2, 1]; headit("closure freeze BETWEEN circular overload"); #print Dumper $nasty; $icicle = freeze $nasty; #print $icicle; headit("circular thaw BETWEEN circular overload"); $oh_dear = thaw $icicle; is(ref($oh_dear), "ARRAY", "dclone - between a closure dclone"); is($oh_dear->[0], "keep it so", "amagic ok 1"); is($oh_dear->[$dbun?2:0]->[0], "keep it so", "amagic ok 2"); @{$nasty} = @{$nasty}[1, 0, 2]; headit("closure freeze BEFORE circular overload"); #print Dumper $nasty; $icicle = freeze $nasty; #print $icicle; headit("circular thaw BEFORE circular overload"); $oh_dear = thaw $icicle; is(ref($oh_dear), "ARRAY", "dclone - after a closure dclone"); is($oh_dear->[1], "keep it so", "amagic ok 1"); is($oh_dear->[$dbun+1]->[0], "keep it so", "amagic ok 2"); } sub headit { return; # comment out to get headings - useful for scanning # output with $Storable::DEBUGME = 1 my $title = shift; my $size_left = (66 - length($title)) >> 1; my $size_right = (67 - length($title)) >> 1; print "# ".("-" x $size_left). " $title " .("-" x $size_right)."\n"; } ��make_56_interwork.pl��0000644��00000002711�15125143264�0010440 0��ustar�00��#!/usr/bin/perl -w use strict; use Config; use Storable qw(freeze thaw); # Lilliput decreed that eggs should be eaten small end first. # Belfuscu welcomed the rebels who wanted to eat big end first. my $kingdom = $Config{byteorder} =~ /23/ ? "Lillput" : "Belfuscu"; my $frozen = freeze ["This file was written with $Storable::VERSION on perl $]", "$kingdom was correct", (~0 ^ (~0 >> 1) ^ 2), "The End"]; my $ivsize = $Config{ivsize} \|\| $Config{longsize}; my $storesize = unpack 'xxC', $frozen; my $storebyteorder = unpack "xxxA$storesize", $frozen; if ($Config{byteorder} eq $storebyteorder) { my $ivtype = $Config{ivtype} \|\| 'long'; print <<"EOM"; You only need to run this generator program where Config.pm's byteorder string is not the same length as the size of IVs. This length difference should only happen on perl 5.6.x configured with IVs as long long on Unix, OS/2 or any platform that runs the Configure stript (ie not MS Windows) This is perl $], sizeof(long) is $Config{longsize}, IVs are '$ivtype', sizeof(IV) is $ivsize, byteorder is '$Config{byteorder}', Storable $Storable::VERSION writes a byteorder of '$storebyteorder' EOM exit; # Grr ' } my ($i, $l, $p, $n) = unpack "xxxx${storesize}CCCC", $frozen; print <<"EOM"; # byteorder '$storebyteorder' # sizeof(int) $i # sizeof(long) $l # sizeof(char ) $p # sizeof(NV) $n EOM my $uu = pack 'u', $frozen; printf "begin %3o $kingdom,$i,$l,$p,$n\n", ord 'A'; print $uu; print "\nend\n\n"; ��attach.t��0000644��00000001757�15125143264�0006212 0��ustar�00��#!./perl -w # # This file tests that Storable correctly uses STORABLE_attach hooks sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use Test::More tests => 3; use Storable (); { my $destruct_cnt = 0; my $obj = bless {data => 'ok'}, 'My::WithDestructor'; my $target = Storable::thaw( Storable::freeze( $obj ) ); is( $target->{data}, 'ok', 'We got correct object after freeze/thaw' ); is( $destruct_cnt, 0, 'No tmp objects created by Storable' ); undef $obj; undef $target; is( $destruct_cnt, 2, 'Only right objects destroyed at the end' ); package My::WithDestructor; sub STORABLE_freeze { my ($self, $clone) = @_; return $self->{data}; } sub STORABLE_attach { my ($class, $clone, $string) = @_; return bless {data => $string}, 'My::WithDestructor'; } sub DESTROY { $destruct_cnt++; } } ��destroy.t��0000644��00000000556�15125143264�0006433 0��ustar�00��# [perl #118139] crash in global destruction when accessing the freed cxt. use Test::More tests => 1; use Storable; BEGIN { store {}, "foo"; } package foo; sub new { return bless {} } DESTROY { open FH, '<', "foo" or die $!; eval { Storable::pretrieve(FH); }; close FH or die $!; unlink "foo"; } package main; # print "# $^X\n"; $x = foo->new(); ok(1); ��testlib.pl��0000644��00000001537�15125143264�0006560 0��ustar�00��#!perl -w use strict; our $file = "storable-testfile.$$"; die "Temporary file '$file' already exists" if -e $file; END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }} use Storable qw (store retrieve freeze thaw nstore nfreeze); sub slurp { my $file = shift; local (FH, $/); open FH, "<", $file or die "Can't open '$file': $!"; binmode FH; my $contents = <FH>; die "Can't read $file: $!" unless defined $contents; return $contents; } sub store_and_retrieve { my $data = shift; unlink $file or die "Can't unlink '$file': $!"; local FH; open FH, ">", $file or die "Can't open '$file': $!"; binmode FH; print FH $data or die "Can't print to '$file': $!"; close FH or die "Can't close '$file': $!"; return eval {retrieve $file}; } sub freeze_and_thaw { my $data = shift; return eval {thaw $data}; } 1; ��canonical.t��0000644��00000006723�15125143264�0006673 0��ustar�00��#!./perl # # Copyright (c) 1995-2000, Raphael Manfredi # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use Storable qw(freeze thaw dclone); our ($debugging, $verbose); use Test::More tests => 8; # Uncomment the following line to get a dump of the constructed data structure # (you may want to reduce the size of the hashes too) # $debugging = 1; $hashsize = 100; $maxhash2size = 100; $maxarraysize = 100; # Use Digest::MD5 if its available to make random string keys eval { require Digest::MD5; }; $gotmd5 = !$@; note "Will use Digest::MD5" if $gotmd5; # Use Data::Dumper if debugging and it is available to create an ASCII dump if ($debugging) { eval { require "Data/Dumper.pm" }; $gotdd = !$@; } @fixed_strings = ("January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December" ); # Build some arbitrarily complex data structure starting with a top level hash # (deeper levels contain scalars, references to hashes or references to arrays); for (my $i = 0; $i < $hashsize; $i++) { my($k) = int(rand(1_000_000)); $k = Digest::MD5::md5_hex($k) if $gotmd5 and int(rand(2)); $a1{$k} = { key => "$k", "value" => $i }; # A third of the elements are references to further hashes if (int(rand(1.5))) { my($hash2) = {}; my($hash2size) = int(rand($maxhash2size)); while ($hash2size--) { my($k2) = $k . $i . int(rand(100)); $hash2->{$k2} = $fixed_strings[rand(int(@fixed_strings))]; } $a1{$k}->{value} = $hash2; } # A further third are references to arrays elsif (int(rand(2))) { my($arr_ref) = []; my($arraysize) = int(rand($maxarraysize)); while ($arraysize--) { push(@$arr_ref, $fixed_strings[rand(int(@fixed_strings))]); } $a1{$k}->{value} = $arr_ref; } } print STDERR Data::Dumper::Dumper(\%a1) if ($verbose and $gotdd); # Copy the hash, element by element in order of the keys foreach $k (sort keys %a1) { $a2{$k} = { key => "$k", "value" => $a1{$k}->{value} }; } # Deep clone the hash $a3 = dclone(\%a1); # In canonical mode the frozen representation of each of the hashes # should be identical $Storable::canonical = 1; $x1 = freeze(\%a1); $x2 = freeze(\%a2); $x3 = freeze($a3); cmp_ok(length $x1, '>', $hashsize); # sanity check is(length $x1, length $x2); # idem is($x1, $x2); is($x1, $x3); # In normal mode it is exceedingly unlikely that the frozen # representations of all the hashes will be the same (normally the hash # elements are frozen in the order they are stored internally, # i.e. pseudo-randomly). $Storable::canonical = 0; $x1 = freeze(\%a1); $x2 = freeze(\%a2); $x3 = freeze($a3); # Two out of three the same may be a coincidence, all three the same # is much, much more unlikely. Still it could happen, so this test # may report a false negative. ok(($x1 ne $x2) \|\| ($x1 ne $x3)); # Ensure refs to "undef" values are properly shared # Same test as in t/dclone.t to ensure the "canonical" code is also correct my $hash; push @{$$hash{''}}, \$$hash{a}; is($$hash{''}[0], \$$hash{a}); my $cloned = dclone(dclone($hash)); is($$cloned{''}[0], \$$cloned{a}); $$cloned{a} = "blah"; is($$cloned{''}[0], \$$cloned{a}); ��dclone.t��0000644��00000004436�15125143264�0006207 0��ustar�00��#!./perl # # Copyright (c) 1995-2000, Raphael Manfredi # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } require 'st-dump.pl'; } use Storable qw(dclone); use Test::More tests => 14; $a = 'toto'; $b = \$a; $c = bless {}, CLASS; $c->{attribute} = 'attrval'; %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); @a = ('first', undef, 3, -4, -3.14159, 456, 4.5, $b, \$a, $a, $c, \$c, \%a); my $aref = dclone(\@a); isnt($aref, undef); $dumped = &dump(\@a); isnt($dumped, undef); $got = &dump($aref); isnt($got, undef); is($got, $dumped); package FOO; @ISA = qw(Storable); sub make { my $self = bless {}; $self->{key} = \%main::a; return $self; }; package main; $foo = FOO->make; my $r = $foo->dclone; isnt($r, undef); is(&dump($foo), &dump($r)); # Ensure refs to "undef" values are properly shared during cloning my $hash; push @{$$hash{''}}, \$$hash{a}; is($$hash{''}[0], \$$hash{a}); my $cloned = dclone(dclone($hash)); is($$cloned{''}[0], \$$cloned{a}); $$cloned{a} = "blah"; is($$cloned{''}[0], \$$cloned{a}); # [ID 20020221.007 (#8624)] SEGV in Storable with empty string scalar object package TestString; sub new { my ($type, $string) = @_; return bless(\$string, $type); } package main; my $empty_string_obj = TestString->new(''); my $clone = dclone($empty_string_obj); # If still here after the dclone the fix (#17543) worked. is(ref $clone, ref $empty_string_obj); is($$clone, $$empty_string_obj); is($$clone, ''); SKIP: { # Do not fail if Tie::Hash and/or Tie::StdHash is not available skip 'No Tie::StdHash available', 2 unless eval { require Tie::Hash; scalar keys %Tie::StdHash:: }; skip 'This version of perl has problems with Tie::StdHash', 2 if $] eq "5.008"; tie my %tie, "Tie::StdHash" or die $!; $tie{array} = [1,2,3,4]; $tie{hash} = {1,2,3,4}; my $clone_array = dclone $tie{array}; is("@$clone_array", "@{$tie{array}}"); my $clone_hash = dclone $tie{hash}; is($clone_hash->{1}, $tie{hash}{1}); } ��malice.t��0000644��00000024526�15125143264�0006177 0��ustar�00��#!./perl -w # # Copyright 2002, Larry Wall. # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # # I'm trying to keep this test easily backwards compatible to 5.004, so no # qr//; # This test tries to craft malicious data to test out as many different # error traps in Storable as possible # It also acts as a test for read_header sub BEGIN { # This lets us distribute Test::More in t/ unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use strict; our $byteorder = $Config{byteorder}; our $file_magic_str = 'pst0'; our $other_magic = 7 + length $byteorder; our $network_magic = 2; our $major = 2; our $minor = 11; our $minor_write = $] >= 5.019 ? 11 : $] > 5.008 ? 9 : $] > 5.005_50 ? 8 : 4; use Test::More; # If it's 5.7.3 or later the hash will be stored with flags, which is # 2 extra bytes. There are 2 * 2 * 2 tests per byte in the body and header # common to normal and network order serialised objects (hence the 8) # There are only 2 * 2 tests per byte in the parts of the header not present # for network order, and 2 tests per byte on the 'pst0' "magic number" only # present in files, but not in things store()ed to memory our $fancy = ($] > 5.007 ? 2 : 0); plan tests => 372 + length ($byteorder) * 4 + $fancy * 8; use Storable qw (store retrieve freeze thaw nstore nfreeze); require 'testlib.pl'; our $file; # The chr 256 is a hack to force the hash to always have the utf8 keys flag # set on 5.7.3 and later. Otherwise the test fails if run with -Mutf8 because # only there does the hash has the flag on, and hence only there is it stored # as a flagged hash, which is 2 bytes longer my %hash = (perl => 'rules', chr 256, ''); delete $hash{chr 256}; sub test_hash { my $clone = shift; is (ref $clone, "HASH", "Get hash back"); is (scalar keys %$clone, 1, "with 1 key"); is ((keys %$clone)[0], "perl", "which is correct"); is ($clone->{perl}, "rules", "Got expected value when looking up key in clone"); } sub test_header { my ($header, $isfile, $isnetorder) = @_; is (!!$header->{file}, !!$isfile, "is file"); is ($header->{major}, $major, "major number"); is ($header->{minor}, $minor_write, "minor number"); is (!!$header->{netorder}, !!$isnetorder, "is network order"); if ($isnetorder) { # Network order header has no sizes } else { is ($header->{byteorder}, $byteorder, "byte order"); is ($header->{intsize}, $Config{intsize}, "int size"); is ($header->{longsize}, $Config{longsize}, "long size"); SKIP: { skip ("No \$Config{prtsize} on this perl version ($])", 1) unless defined $Config{ptrsize}; is ($header->{ptrsize}, $Config{ptrsize}, "long size"); } is ($header->{nvsize}, $Config{nvsize} \|\| $Config{doublesize} \|\| 8, "nv size"); # 5.00405 doesn't even have doublesize in config. } } sub test_truncated { my ($data, $sub, $magic_len, $what) = @_; for my $i (0 .. length ($data) - 1) { my $short = substr $data, 0, $i; # local $Storable::DEBUGME = 1; my $clone = &$sub($short); is (defined ($clone), '', "truncated $what to $i should fail"); if ($i < $magic_len) { like ($@, "/^Magic number checking on storable $what failed/", "Should croak with magic number warning"); } else { is ($@, "", "Should not set \$\@"); } } } sub test_corrupt { my ($data, $sub, $what, $name) = @_; my $clone = &$sub($data); local $Test::Builder::Level = $Test::Builder::Level + 1; is (defined ($clone), '', "$name $what should fail"); like ($@, $what, $name); } sub test_things { my ($contents, $sub, $what, $isnetwork) = @_; my $isfile = $what eq 'file'; my $file_magic = $isfile ? length $file_magic_str : 0; my $header = Storable::read_magic ($contents); test_header ($header, $isfile, $isnetwork); # Test that if we re-write it, everything still works: my $clone = &$sub ($contents); is ($@, "", "There should be no error"); test_hash ($clone); # Now lets check the short version: test_truncated ($contents, $sub, $file_magic + ($isnetwork ? $network_magic : $other_magic), $what); my $copy; if ($isfile) { $copy = $contents; substr ($copy, 0, 4) = 'iron'; test_corrupt ($copy, $sub, "/^File is not a perl storable/", "magic number"); } $copy = $contents; # Needs to be more than 1, as we're already coding a spread of 1 minor version # number on writes (2.5, 2.4). May increase to 2 if we figure we can do 2.3 # on 5.005_03 (No utf8). # 4 allows for a small safety margin # Which we've now exhausted given that Storable 2.25 is writing 2.8 # (Joke: # Question: What is the value of pi? # Mathematician answers "It's pi, isn't it" # Physicist answers "3.1, within experimental error" # Engineer answers "Well, allowing for a small safety margin, 18" # ) my $minor6 = $header->{minor} + 6; substr ($copy, $file_magic + 1, 1) = chr $minor6; { # Now by default newer minor version numbers are not a pain. $clone = &$sub($copy); is ($@, "", "by default no error on higher minor"); test_hash ($clone); local $Storable::accept_future_minor = 0; test_corrupt ($copy, $sub, "/^Storable binary image v$header->{major}\.$minor6 more recent than I am \\(v$header->{major}\.$minor\\)/", "higher minor"); } $copy = $contents; my $major1 = $header->{major} + 1; substr ($copy, $file_magic, 1) = chr 2$major1; test_corrupt ($copy, $sub, "/^Storable binary image v$major1\.$header->{minor} more recent than I am \\(v$header->{major}\.$minor\\)/", "higher major"); # Continue messing with the previous copy my $minor1 = $header->{minor} - 1; substr ($copy, $file_magic + 1, 1) = chr $minor1; test_corrupt ($copy, $sub, "/^Storable binary image v$major1\.$minor1 more recent than I am \\(v$header->{major}\.$minor\\)/", "higher major, lower minor"); my $where; if (!$isnetwork) { # All these are omitted from the network order header. # I'm not sure if it's correct to omit the byte size stuff. $copy = $contents; substr ($copy, $file_magic + 3, length $header->{byteorder}) = reverse $header->{byteorder}; test_corrupt ($copy, $sub, "/^Byte order is not compatible/", "byte order"); $where = $file_magic + 3 + length $header->{byteorder}; foreach (['intsize', "Integer"], ['longsize', "Long integer"], ['ptrsize', "Pointer"], ['nvsize', "Double"]) { my ($key, $name) = @$_; $copy = $contents; substr ($copy, $where++, 1) = chr 0; test_corrupt ($copy, $sub, "/^$name size is not compatible/", "$name size"); } } else { $where = $file_magic + $network_magic; } # Just the header and a tag 255. As 33 is currently the highest tag, this # is "unexpected" $copy = substr ($contents, 0, $where) . chr 255; test_corrupt ($copy, $sub, "/^Corrupted storable $what \\(binary v$header->{major}.$header->{minor}\\)/", "bogus tag"); # Now drop the minor version number substr ($copy, $file_magic + 1, 1) = chr $minor1; test_corrupt ($copy, $sub, "/^Corrupted storable $what \\(binary v$header->{major}.$minor1\\)/", "bogus tag, minor less 1"); # Now increase the minor version number substr ($copy, $file_magic + 1, 1) = chr $minor6; # local $Storable::DEBUGME = 1; # This is the delayed croak test_corrupt ($copy, $sub, "/^Storable binary image v$header->{major}.$minor6 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 33/", "bogus tag, minor plus 4"); # And check again that this croak is not delayed: { # local $Storable::DEBUGME = 1; local $Storable::accept_future_minor = 0; test_corrupt ($copy, $sub, "/^Storable binary image v$header->{major}\.$minor6 more recent than I am \\(v$header->{major}\.$minor\\)/", "higher minor"); } } ok (defined store(\%hash, $file), "store() returned defined value"); my $expected = 20 + length ($file_magic_str) + $other_magic + $fancy; my $length = -s $file; die "Don't seem to have written file '$file' as I can't get its length: $!" unless defined $file; die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length" unless $length == $expected; # Read the contents into memory: my $contents = slurp ($file); # Test the original direct from disk my $clone = retrieve $file; test_hash ($clone); # Then test it. test_things($contents, \&store_and_retrieve, 'file'); # And now try almost everything again with a Storable string my $stored = freeze \%hash; test_things($stored, \&freeze_and_thaw, 'string'); # Network order. unlink $file or die "Can't unlink '$file': $!"; ok (defined nstore(\%hash, $file), "nstore() returned defined value"); $expected = 20 + length ($file_magic_str) + $network_magic + $fancy; $length = -s $file; die "Don't seem to have written file '$file' as I can't get its length: $!" unless defined $file; die "Expected file to be $expected bytes (sizeof long is $Config{longsize}) but it is $length" unless $length == $expected; # Read the contents into memory: $contents = slurp ($file); # Test the original direct from disk $clone = retrieve $file; test_hash ($clone); # Then test it. test_things($contents, \&store_and_retrieve, 'file', 1); # And now try almost everything again with a Storable string $stored = nfreeze \%hash; test_things($stored, \&freeze_and_thaw, 'string', 1); # Test that the bug fixed by #20587 doesn't affect us under some older # Perl. AMS 20030901 { chop(my $a = chr(0xDF).chr(256)); my %a = (chr(0xDF) => 1); $a{$a}++; freeze \%a; # If we were built with -DDEBUGGING, the assert() should have killed # us, which will probably alert the user that something went wrong. ok(1); } # Unusual in that the empty string is stored with an SX_LSCALAR marker my $hash = store_and_retrieve("pst0\5\6\3\0\0\0\1\1\0\0\0\0\0\0\0\5empty"); ok(!$@, "no exception"); is(ref($hash), "HASH", "got a hash"); is($hash->{empty}, "", "got empty element"); ��tied_items.t��0000644��00000002164�15125143264�0007065 0��ustar�00��#!./perl # # Copyright (c) 1995-2000, Raphael Manfredi # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # # # Tests ref to items in tied hash/array structures. # sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } $^W = 0; use Storable qw(dclone); use Test::More tests => 8; $Storable::flags = Storable::FLAGS_COMPAT; $h_fetches = 0; sub H::TIEHASH { bless \(my $x), "H" } sub H::FETCH { $h_fetches++; $_[1] - 70 } tie %h, "H"; $ref = \$h{77}; $ref2 = dclone $ref; is($h_fetches, 0); is($$ref2, $$ref); is($$ref2, 7); is($h_fetches, 2); $a_fetches = 0; sub A::TIEARRAY { bless \(my $x), "A" } sub A::FETCH { $a_fetches++; $_[1] - 70 } tie @a, "A"; $ref = \$a[78]; $ref2 = dclone $ref; is($a_fetches, 0); is($$ref2, $$ref); is($$ref2, 8); # a bug in 5.12 and earlier caused an extra FETCH is($a_fetches, $] < 5.013 ? 3 : 2); ��integer.t��0000644��00000013472�15125143264�0006400 0��ustar�00��#!./perl -w # # Copyright 2002, Larry Wall. # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # # I ought to keep this test easily backwards compatible to 5.004, so no # qr//; # This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features # are encountered. sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use Test::More; use Storable qw (dclone store retrieve freeze thaw nstore nfreeze); use strict; my $max_uv = ~0; my $max_uv_m1 = ~0 ^ 1; # Express it in this way so as not to use any addition, as 5.6 maths would # do this in NVs on 64 bit machines, and we're overflowing IVs so can't use # use integer. my $max_iv_p1 = $max_uv ^ ($max_uv >> 1); my $lots_of_9C = do { my $temp = sprintf "%#x", ~0; $temp =~ s/ff/9c/g; local $^W; eval $temp; }; my $max_iv = ~0 >> 1; my $min_iv = do {use integer; -$max_iv-1}; # 2s complement assumption my @processes = (["dclone", \&do_clone], ["freeze/thaw", \&freeze_and_thaw], ["nfreeze/thaw", \&nfreeze_and_thaw], ["store/retrieve", \&store_and_retrieve], ["nstore/retrieve", \&nstore_and_retrieve], ); my @numbers = (# IV bounds of 8 bits -1, 0, 1, -127, -128, -129, 42, 126, 127, 128, 129, 254, 255, 256, 257, # IV bounds of 32 bits -2147483647, -2147483648, -2147483649, 2147483646, 2147483647, 2147483648, # IV bounds $min_iv, do {use integer; $min_iv + 1}, do {use integer; $max_iv - 1}, $max_iv, # UV bounds at 32 bits 0x7FFFFFFF, 0x80000000, 0x80000001, 0xFFFFFFFF, 0xDEADBEEF, # UV bounds $max_iv_p1, $max_uv_m1, $max_uv, $lots_of_9C, # NV-UV conversion 2559831922.0, ); plan tests => @processes @numbers * 5; my $file = "integer.$$"; die "Temporary file '$file' already exists" if -e $file; END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }} sub do_clone { my $data = shift; my $copy = eval {dclone $data}; is ($@, '', 'Should be no error dcloning'); ok (1, "dlcone is only 1 process, not 2"); return $copy; } sub freeze_and_thaw { my $data = shift; my $frozen = eval {freeze $data}; is ($@, '', 'Should be no error freezing'); my $copy = eval {thaw $frozen}; is ($@, '', 'Should be no error thawing'); return $copy; } sub nfreeze_and_thaw { my $data = shift; my $frozen = eval {nfreeze $data}; is ($@, '', 'Should be no error nfreezing'); my $copy = eval {thaw $frozen}; is ($@, '', 'Should be no error thawing'); return $copy; } sub store_and_retrieve { my $data = shift; my $frozen = eval {store $data, $file}; is ($@, '', 'Should be no error storing'); my $copy = eval {retrieve $file}; is ($@, '', 'Should be no error retrieving'); return $copy; } sub nstore_and_retrieve { my $data = shift; my $frozen = eval {nstore $data, $file}; is ($@, '', 'Should be no error storing'); my $copy = eval {retrieve $file}; is ($@, '', 'Should be no error retrieving'); return $copy; } foreach (@processes) { my ($process, $sub) = @$_; foreach my $number (@numbers) { # as $number is an alias into @numbers, we don't want any side effects of # conversion macros affecting later runs, so pass a copy to Storable: my $copy1 = my $copy2 = my $copy0 = $number; my $copy_s = &$sub (\$copy0); if (is (ref $copy_s, "SCALAR", "got back a scalar ref?")) { # Test inside use integer to see if the bit pattern is identical # and outside to see if the sign is right. # On 5.8 we don't need this trickery anymore. # We really do need 2 copies here, as conversion may have side effect # bugs. In particular, I know that this happens: # perl5.00503 -le '$a = "-2147483649"; $a & 0; print $a; print $a+1' # -2147483649 # 2147483648 my $copy_s1 = my $copy_s2 = $$copy_s; # On 5.8 can do this with a straight ==, due to the integer/float maths # on 5.6 can't do this with # my $eq = do {use integer; $copy_s1 == $copy1} && $copy_s1 == $copy1; # because on builds with IV as long long it tickles bugs. # (Uncomment it and the Devel::Peek line below to see the messed up # state of the scalar, with PV showing the correct string for the # number, and IV holding a bogus value which has been truncated to 32 bits # So, check the bit patterns are identical, and check that the sign is the # same. This works on all the versions in all the sizes. # $eq = && (($copy_s1 <=> 0) == ($copy1 <=> 0)); # Split this into 2 tests, to cater for 5.005_03 # Aargh. Even this doesn't work because 5.6.x sends values with (same # number of decimal digits as ~0 + 1) via atof. So ^ is getting strings # cast to doubles cast to integers. And that truncates low order bits. # my $bit = ok (($copy_s1 ^ $copy1) == 0, "$process $copy1 (bitpattern)"); # Oh well; at least the parser gets it right. :-) my $copy_s3 = eval $copy_s1; die "Was supposed to have number $copy_s3, got error $@" unless defined $copy_s3; my $bit = ok (($copy_s3 ^ $copy1) == 0, "$process $copy1 (bitpattern)"); my $sign = ok (($copy_s2 <=> 0) == ($copy2 <=> 0), "$process $copy1 (sign)"); unless ($bit and $sign) { printf "# Passed in %s (%#x, %i)\n# got back '%s' (%#x, %i)\n", $copy1, $copy1, $copy1, $copy_s1, $copy_s1, $copy_s1; # use Devel::Peek; Dump $number; Dump $copy1; Dump $copy_s1; } # unless ($bit) { use Devel::Peek; Dump $copy_s1; Dump $$copy_s; } } else { fail ("$process $copy1"); fail ("$process $copy1"); } } } ��circular_hook.t��0000644��00000003747�15125143264�0007573 0��ustar�00��#!./perl -w # # Copyright 2005, Adam Kennedy. # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # # Man, blessed.t scared the hell out of me. For a second there I thought # I'd lose Test::More... # This file tests several known-error cases relating to STORABLE_attach, in # which Storable should (correctly) throw errors. sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } } use Storable (); use Test::More tests => 9; my $ddd = bless { }, 'Foo'; my $eee = bless { Bar => $ddd }, 'Bar'; $ddd->{Foo} = $eee; my $array = [ $ddd ]; my $string = Storable::freeze( $array ); my $thawed = Storable::thaw( $string ); # is_deeply infinite loops in circulars, so do it manually # is_deeply( $array, $thawed, 'Circular hooked objects work' ); is( ref($thawed), 'ARRAY', 'Top level ARRAY' ); is( scalar(@$thawed), 1, 'ARRAY contains one element' ); isa_ok( $thawed->[0], 'Foo' ); is( scalar(keys %{$thawed->[0]}), 1, 'Foo contains one element' ); isa_ok( $thawed->[0]->{Foo}, 'Bar' ); is( scalar(keys %{$thawed->[0]->{Foo}}), 1, 'Bar contains one element' ); isa_ok( $thawed->[0]->{Foo}->{Bar}, 'Foo' ); is( $thawed->[0], $thawed->[0]->{Foo}->{Bar}, 'Circular is... well... circular' ); # Make sure the thawing went the way we expected is_deeply( \@Foo::order, [ 'Bar', 'Foo' ], 'thaw order is correct (depth first)' ); package Foo; @order = (); sub STORABLE_freeze { my ($self, $clone) = @_; my $class = ref $self; # print "# Freezing $class\n"; return ($class, $self->{$class}); } sub STORABLE_thaw { my ($self, $clone, $string, @refs) = @_; my $class = ref $self; # print "# Thawing $class\n"; $self->{$class} = shift @refs; push @order, $class; return; } package Bar; BEGIN { @ISA = 'Foo'; } 1; ��tied.t��0000644��00000010236�15125143264�0005663 0��ustar�00��#!./perl # # Copyright (c) 1995-2000, Raphael Manfredi # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # sub BEGIN { unshift @INC, 't'; unshift @INC, 't/compat' if $] < 5.006002; require Config; import Config; if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { print "1..0 # Skip: Storable was not built\n"; exit 0; } require 'st-dump.pl'; } use Storable qw(freeze thaw); $Storable::flags = Storable::FLAGS_COMPAT; use Test::More tests => 25; ($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0); package TIED_HASH; sub TIEHASH { my $self = bless {}, shift; return $self; } sub FETCH { my $self = shift; my ($key) = @_; $main::hash_fetch++; return $self->{$key}; } sub STORE { my $self = shift; my ($key, $value) = @_; $self->{$key} = $value; } sub FIRSTKEY { my $self = shift; scalar keys %{$self}; return each %{$self}; } sub NEXTKEY { my $self = shift; return each %{$self}; } package TIED_ARRAY; sub TIEARRAY { my $self = bless [], shift; return $self; } sub FETCH { my $self = shift; my ($idx) = @_; $main::array_fetch++; return $self->[$idx]; } sub STORE { my $self = shift; my ($idx, $value) = @_; $self->[$idx] = $value; } sub FETCHSIZE { my $self = shift; return @{$self}; } package TIED_SCALAR; sub TIESCALAR { my $scalar; my $self = bless \$scalar, shift; return $self; } sub FETCH { my $self = shift; $main::scalar_fetch++; return $$self; } sub STORE { my $self = shift; my ($value) = @_; $$self = $value; } package FAULT; $fault = 0; sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; } sub FETCH { my $self = shift; my ($href, $key) = @$self; $fault++; untie $href->{$key}; return $href->{$key} = 1; } package main; $a = 'toto'; $b = \$a; $c = tie %hash, TIED_HASH; $d = tie @array, TIED_ARRAY; tie $scalar, TIED_SCALAR; #$scalar = 'foo'; #$hash{'attribute'} = \$d; #$array[0] = $c; #$array[1] = \$scalar; ### If I say ### $hash{'attribute'} = $d; ### below, then dump() incorrectly dumps the hash value as a string the second ### time it is reached. I have not investigated enough to tell whether it's ### a bug in my dump() routine or in the Perl tieing mechanism. $scalar = 'foo'; $hash{'attribute'} = 'plain value'; $array[0] = \$scalar; $array[1] = $c; $array[2] = \@array; @tied = (\$scalar, \@array, \%hash); %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$a, 'scalarref', \$scalar); @a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d, $b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied); my $f = freeze(\@a); isnt($f, undef); $dumped = &dump(\@a); isnt($dumped, undef); $root = thaw($f); isnt($root, undef); $got = &dump($root); isnt($got, undef); ### Used to see the manifestation of the bug documented above. ### print "original: $dumped"; ### print "--------\n"; ### print "got: $got"; ### print "--------\n"; is($got, $dumped); $g = freeze($root); is(length $f, length $g); # Ensure the tied items in the retrieved image work @old = ($scalar_fetch, $array_fetch, $hash_fetch); @tied = ($tscalar, $tarray, $thash) = @{$root->[$#{$root}]}; @type = qw(SCALAR ARRAY HASH); is(ref tied $$tscalar, 'TIED_SCALAR'); is(ref tied @$tarray, 'TIED_ARRAY'); is(ref tied %$thash, 'TIED_HASH'); @new = ($$tscalar, $tarray->[0], $thash->{'attribute'}); @new = ($scalar_fetch, $array_fetch, $hash_fetch); # Tests 10..15 for ($i = 0; $i < @new; $i++) { is($new[$i], $old[$i] + 1); is(ref $tied[$i], $type[$i]); } # Check undef ties my $h = {}; tie $h->{'x'}, 'FAULT', $h, 'x'; my $hf = freeze($h); isnt($hf, undef); is($FAULT::fault, 0); is($h->{'x'}, 1); is($FAULT::fault, 1); my $ht = thaw($hf); isnt($ht, undef); is($ht->{'x'}, 1); is($FAULT::fault, 2); { package P; use Storable qw(freeze thaw); our ($a, $b); $b = "not ok "; sub TIESCALAR { bless \$a } sub FETCH { "ok " } tie $a, P; my $r = thaw freeze \$a; $b = $$r; main::is($b, "ok "); } { # blessed ref to tied object should be thawed blessed my @a; tie @a, TIED_ARRAY; my $r = bless \@a, 'FOO99'; my $f = freeze($r); my $t = thaw($f); isnt($t, undef); like("$t", qr/^FOO99=ARRAY/); } ��05_honor_prior_override.t��0000644��00000005121�15125143266�0011500 0��ustar�00��#!/usr/bin/perl use strict; BEGIN { $^W = 1 } use Test::More tests => 10; # Goal of these tests: confirm that Sub::Uplevel will honor (use) a # CORE::GLOBAL::caller override that occurs prior to Sub::Uplevel loading #--------------------------------------------------------------------------# # define a custom caller function that increments a counter #--------------------------------------------------------------------------# my $caller_counter = 0; sub _count_caller(;$) { $caller_counter++; my $height = $_[0]; my @caller = CORE::caller(++$height); if( wantarray and !@_ ) { return @caller[0..2]; } elsif (wantarray) { return @caller; } else { return $caller[0]; } } #--------------------------------------------------------------------------# # redefine CORE::GLOBAL::caller then load Sub::Uplevel #--------------------------------------------------------------------------# BEGIN { ok( ! defined CORE::GLOBAL::caller{CODE}, "no global override yet" ); { # old style no warnings 'redefine' my $old_W = $^W; $^W = 0; CORE::GLOBAL::caller = \&_count_caller; $^W = $old_W; } is( CORE::GLOBAL::caller{CODE}, \&_count_caller, "added custom caller override" ); use_ok('Sub::Uplevel'); is( CORE::GLOBAL::caller{CODE}, \&_count_caller, "custom caller override still in place" ); } #--------------------------------------------------------------------------# # define subs after caller has been redefined in BEGIN #--------------------------------------------------------------------------# sub test_caller { return scalar caller } sub uplevel_caller { return uplevel 1, \&test_caller } sub test_caller_w_uplevel { return uplevel_caller } #--------------------------------------------------------------------------# # Test for reversed package name both inside and outside an uplevel call #--------------------------------------------------------------------------# my $old_caller_counter; $old_caller_counter = $caller_counter; is( scalar caller(), undef, "caller from main package is undef" ); ok( $caller_counter > $old_caller_counter, "custom caller() was used" ); $old_caller_counter = $caller_counter; is( test_caller(), "main", "caller from subroutine is main" ); ok( $caller_counter > $old_caller_counter, "custom caller() was used" ); $old_caller_counter = $caller_counter; is( test_caller_w_uplevel(), "main", "caller from uplevel subroutine is main" ); ok( $caller_counter > $old_caller_counter, "custom caller() was used" ); ��09_emptylist.t��0000644��00000001004�15125143266�0007273 0��ustar�00��#!/usr/bin/perl use strict; BEGIN { $^W = 1 } use Test::More; use Sub::Uplevel; plan tests => 3; sub get_caller { return caller(shift); } sub wrapper { my $height = shift; return uplevel 1, \&get_caller, $height; } { my @caller = wrapper(0); ok(scalar @caller, "caller(N) in stack returns list"); } { my @caller = wrapper(1); is(scalar @caller, 0, "caller(N) out of stack returns empty list"); } { my @caller = caller; is(scalar @caller, 0, "caller from main returns empty list"); } ��02_uplevel.t��0000644��00000010726�15125143266�0006721 0��ustar�00��#!/usr/bin/perl use strict; BEGIN { $^W = 1 } use Test::More tests => 23; BEGIN { use_ok('Sub::Uplevel'); } can_ok('Sub::Uplevel', 'uplevel'); can_ok(__PACKAGE__, 'uplevel'); #line 11 ok( !caller, "top-level caller() not screwed up" ); eval { die }; is( $@, "Died at $0 line 13.\n", 'die() not screwed up' ); sub foo { join " - ", caller; } sub bar { uplevel(1, \&foo); } #line 25 is( bar(), "main - $0 - 25", 'uplevel()' ); # Sure, but does it fool die? sub try_die { die "You must die! I alone am best!"; } sub wrap_die { uplevel(1, \&try_die); } # line 38 eval { wrap_die() }; is( $@, "You must die! I alone am best! at $0 line 30.\n", 'die() fooled' ); # how about warn? sub try_warn { warn "HA! You don't fool me!"; } sub wrap_warn { uplevel(1, \&try_warn); } my $warning; { local $SIG{__WARN__} = sub { $warning = join '', @_ }; #line 56 wrap_warn(); } is( $warning, "HA! You don't fool me! at $0 line 44.\n", 'warn() fooled' ); # Carp? use Carp; sub try_croak { # line 64 croak("Now we can fool croak!"); } sub wrap_croak { # line 68 uplevel(shift, \&try_croak); } # depending on perl version, we could get 'require 0' or 'eval {...}' # in the stack. This test used to be 'require 0' for <= 5.006, but # it broke on 5.005_05 test release, so we'll just take either # line 72 eval { wrap_croak(1) }; my $croak_regex = quotemeta( <<"CARP" ); Now we can fool croak! at $0 line 64 main::wrap_croak(1) called at $0 line 72 CARP $croak_regex =~ s/64/64\.?/; # Perl 5.15 series Carp adds period $croak_regex .= '\t(require 0\|eval \{\.\.\.\})' . quotemeta( " called at $0 line 72" ); like( $@, "/$croak_regex/", 'croak() fooled'); # Try to wrap higher -- this may have been a problem that was exposed on # Test Exception # line 75 eval { wrap_croak(2) }; $croak_regex = quotemeta( <<"CARP" ); Now we can fool croak! at $0 line 64 CARP $croak_regex =~ s/64/64\.?/; # Perl 5.15 series Carp adds period like( $@, "/$croak_regex/", 'croak() fooled'); #line 79 ok( !caller, "caller() not screwed up" ); eval { die "Dying" }; is( $@, "Dying at $0 line 81.\n", 'die() not screwed up' ); # how about carp? sub try_carp { # line 88 carp "HA! Even carp is fooled!"; } sub wrap_carp { uplevel(1, \&try_carp); } $warning = ''; { local $SIG{__WARN__} = sub { $warning = join '', @_ }; #line 98 wrap_carp(); } my $carp_regex = quotemeta( <<"CARP" ); HA! Even carp is fooled! at $0 line 88 main::wrap_carp() called at $0 line 98 CARP $carp_regex =~ s/88/88\.?/; # Perl 5.15 series Carp adds period like( $warning, "/$carp_regex/", 'carp() fooled' ); use lib 't/lib'; use Foo; can_ok( 'main', 'fooble' ); #line 114 sub core_caller_check { return CORE::caller(0); } sub caller_check { return caller(shift); } is_deeply( [ ( caller_check(0), 0, 4 )[0 .. 3] ], ['main', $0, 122, 'main::caller_check' ], 'caller check' ); is( (() = caller_check(0)), (() = core_caller_check(0)) , "caller() with args returns right number of values" ); sub core_caller_no_args { return CORE::caller(); } sub caller_no_args { return caller(); } is( (() = caller_no_args()), (() = core_caller_no_args()), "caller() with no args returns right number of values" ); sub deep_caller { return caller(1); } sub check_deep_caller { deep_caller(); } #line 134 is_deeply([(check_deep_caller)[0..2]], ['main', $0, 134], 'shallow caller' ); sub deeper { deep_caller() } # caller 0 sub still_deeper { deeper() } # caller 1 -- should give this line, 137 sub ever_deeper { still_deeper() } # caller 2 is_deeply([(ever_deeper)[0..2]], ['main', $0, 137], 'deep caller()' ); # This uplevel() should not effect deep_caller's caller(1). sub yet_deeper { uplevel( 1, \&ever_deeper) } is_deeply([(yet_deeper)[0..2]], ['main', $0, 137], 'deep caller() + uplevel' ); sub target { caller } sub yarrow { uplevel( 1, \&target ) } sub hock { uplevel( 1, \&yarrow ) } is_deeply([(hock)], ['main', $0, 150], 'nested uplevel()s' ); # Deep caller inside uplevel package Delegator; # line 159 sub delegate { main::caller_check(shift) } package Wrapper; use Sub::Uplevel; sub wrap { uplevel( 1, \&Delegator::delegate, @_ ) } package main; is( (Wrapper::wrap(0))[0], 'Delegator', 'deep caller check of parent sees real calling package' ); is( (Wrapper::wrap(1))[0], 'main', 'deep caller check of grandparent sees package above uplevel' ); ��07_uplevel_too_high.t��0000644��00000001320�15125143266�0010574 0��ustar�00��#!/usr/bin/perl use strict; BEGIN { $^W = 1 } use Test::More tests => 5; BEGIN { $Sub::Uplevel::CHECK_FRAMES = 1; use_ok('Sub::Uplevel'); } sub show_caller { return scalar caller; } sub wrap_show_caller { my $uplevel = shift; return uplevel $uplevel, \&show_caller; } my $warning = ''; local $SIG{__WARN__} = sub { $warning = shift }; my $caller = wrap_show_caller(1); is($caller, 'main', "wrapper returned correct caller"); is( $warning, '', "don't warn if ordinary uplevel" ); $warning = ''; $caller = wrap_show_caller(2); my $file = __FILE__; is($caller, undef, "wrapper returned correct caller"); like( $warning, qr/uplevel 2 is more than the caller stack/, "warn if too much uplevel" ); ��03_nested_uplevels.t��0000644��00000003221�15125143266�0010437 0��ustar�00��#!/usr/bin/perl use strict; BEGIN { $^W = 1 } use Test::More; use Sub::Uplevel; package Wrap; use Sub::Uplevel; sub wrap { my ($n, $f, $depth, $up, @case) = @_; if ($n > 1) { $n--; return wrap( $n, $f, $depth, $up, @case ); } else { return uplevel( $up , $f, $depth, $up, @case ); } } package Call; sub recurse_call_check { my ($depth, $up, @case) = @_; if ( $depth ) { $depth--; my @result; push @result, recurse_call_check($depth, $up, @case, 'Call' ); for my $n ( 1 .. $up ) { push @result, Wrap::wrap( $n, \&recurse_call_check, $depth, $n, @case, $n == 1 ? "Wrap(Call)" : "Wrap(Call) x $n" ), ; } return @result; } else { my (@uplevel_callstack, @real_callstack); my $i = 0; while ( defined( my $caller = caller($i++) ) ) { push @uplevel_callstack, $caller; } $i = 0; while ( defined( my $caller = CORE::caller($i++) ) ) { push @real_callstack, $caller; } return [ join( q{, }, @case ), join( q{, }, reverse @uplevel_callstack ), join( q{, }, reverse @real_callstack ), ]; } } package main; my $depth = 4; my $up = 3; my $cases = 104; plan tests => $cases; my @results = Call::recurse_call_check( $depth, $up, 'Call' ); is( scalar @results, $cases, "Right number of cases" ); my $expected = shift @results; for my $got ( @results ) { is( $got->[1], $expected->[1], "Case: $got->[0]" ) or diag( "Real callers: $got->[2]" ); } ��08_exporter.t��0000644��00000000466�15125143266�0007123 0��ustar�00��#!/usr/bin/perl use strict; BEGIN { $^W = 1 } use Test::More; plan tests => 1; # Goal of these tests: confirm that Sub::Uplevel will work with Exporter's # import() function package main; use lib 't/lib'; require MyImporter; require Bar; MyImporter::import_for_me('Bar','func3'); can_ok('main','func3'); ��01_die_check.t��0000644��00000000712�15125143266�0007134 0��ustar�00��#!/usr/bin/perl # Kirk: How we deal with death is at least as important as how we deal # with life, wouldn't you say? # Saavik: As I indicated, Admiral, that thought had not occurred to me. # Kirk: Well, now you have something new to think about. Carry on. # XXX DG: Why is this test here? Seems pointless. Oh, well. use strict; BEGIN { $^W = 1 } use Test::More tests => 1; #line 12 eval { die }; is( $@, "Died at $0 line 12.\n" ); ��06_db_args.t��0000644��00000001041�15125143266�0006640 0��ustar�00��#!/usr/bin/perl use strict; BEGIN { $^W = 1 } use Test::More tests => 3; BEGIN { use_ok('Sub::Uplevel'); } sub get_caller_args { package DB; my @x = caller(1); return @DB::args; } sub addition { my $x; $x += $_ for @_; return $x; } sub wrap_addition { my @args = get_caller_args(); my $sum = uplevel 1, \&addition, @_; return ($sum, @args); } my ($sum, @args) = wrap_addition(1, 2, 3); is($sum, 6, "wrapper returned value correct"); is_deeply( \@args, [1, 2, 3], "wrapper returned args correct" ); ��04_honor_later_override.t��0000644��00000004436�15125143266�0011463 0��ustar�00��#!/usr/bin/perl use strict; BEGIN { $^W = 1 } use Test::More tests => 7; # Goal of these tests: confirm that Sub::Uplevel will honor (use) a # CORE::GLOBAL::caller that occurs after Sub::Uplevel is loaded #--------------------------------------------------------------------------# # define a custom caller function that reverses the package name #--------------------------------------------------------------------------# sub _reverse_caller(;$) { my $height = $_[0]; my @caller = CORE::caller(++$height); $caller[0] = defined $caller[0] ? reverse $caller[0] : undef; if( wantarray and !@_ ) { return @caller[0..2]; } elsif (wantarray) { return @caller; } else { return $caller[0]; } } #--------------------------------------------------------------------------# # load Sub::Uplevel then redefine CORE::GLOBAL::caller #--------------------------------------------------------------------------# BEGIN { ok( ! defined CORE::GLOBAL::caller{CODE}, "no global override yet" ); use_ok('Sub::Uplevel'); is( CORE::GLOBAL::caller{CODE}, \&Sub::Uplevel::_normal_caller, "Sub::Uplevel's normal caller override in place" ); # old style no warnings 'redefine' my $old_W = $^W; $^W = 0; CORE::GLOBAL::caller = \&_reverse_caller; $^W = $old_W } is( CORE::GLOBAL::caller{CODE}, \&_reverse_caller, "added new, custom caller override" ); #--------------------------------------------------------------------------# # define subs after caller has been redefined in BEGIN #--------------------------------------------------------------------------# sub test_caller { return scalar caller } sub uplevel_caller { return uplevel 1, \&test_caller } sub test_caller_w_uplevel { return uplevel_caller } #--------------------------------------------------------------------------# # Test for reversed package name both inside and outside an uplevel call #--------------------------------------------------------------------------# is( scalar caller(), undef, "caller from main package is undef" ); is( test_caller(), reverse("main"), "caller from subroutine calls custom routine" ); is( test_caller_w_uplevel(), reverse("main"), "caller from uplevel subroutine calls custom routine" ); ��lib/MyImporter.pm��0000644��00000000461�15125143266�0007765 0��ustar�00��package MyImporter; use warnings; use strict; use Sub::Uplevel qw/:aggressive/; sub import_for_me { my ($pkg, @p) = @_; my $level = 1; my $import = $pkg->can('import'); if ($import) { uplevel $level, $import, ($pkg, @p); } else { warn "no import in $pkg\n"; } } 1; ��lib/Foo.pm��0000644��00000000224�15125143266�0006376 0��ustar�00��package Foo; # Hook::LexWrap does this, Sub::Uplevel appears to interfere. sub import { {caller()."::fooble"} = \&fooble } sub fooble { 42 } 1; ��lib/Bar.pm��0000644��00000000203�15125143266�0006354 0��ustar�00��package Bar; use warnings; use strict; require Exporter; our @ISA = qw(Exporter); our @EXPORT_OK = qw( func3 ); sub func3 { 3 } 1; ��03.github-issue-5.t��0000644��00000001275�15125143331�0007727 0��ustar�00��#!/usr/bin/perl # # Test for Github Issue #5 # pathmk doesn't make deep directories # # Created by Joelle Maslak # use strict; use warnings; use Test::More; use File::Temp; use File::Copy::Recursive qw(pathmk); my $tmpd = File::Temp->newdir; note("Temp Dir: $tmpd"); # pathmk() pathmk("$tmpd/1"); ok( ( -d "$tmpd/1" ), "Directories (1 directory deep) are created" ); pathmk("$tmpd/2/2"); ok( ( -d "$tmpd/2/2" ), "Deep directories (2 directories deep) are created" ); pathmk("$tmpd/3/3/3"); ok( ( -d "$tmpd/3/3/3" ), "Deep directories (3 directories deep) are created" ); pathmk("$tmpd/4/4/4/4"); ok( ( -d "$tmpd/4/4/4/4" ), "Deep directories (4 directories deep) are created" ); done_testing; ��01.legacy.t��0000644��00000035243�15125143331�0006421 0��ustar�00��use strict; use warnings; our $curr_unlink = sub { return CORE::unlink(@_) }; # I wish goto would work here :/ BEGIN { no warnings 'redefine'; CORE::GLOBAL::unlink = sub { goto $curr_unlink }; } use Test::More; use Test::Deep; use Test::File; use Test::Warnings 'warnings'; use Path::Tiny; use File::Temp; use File::Copy::Recursive qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir rcopy_glob rmove_glob); umask 022; # for consistent testing note "functionality w/ default globals"; { is( $File::Copy::Recursive::DirPerms, 0777, "DirPerms default is 0777" ); ok( !$File::Copy::Recursive::CPRFComp, "CPRFComp default is false" ); ok( !$File::Copy::Recursive::RMTrgFil, "RMTrgFil default is false" ); my $tmpd = _get_fresh_tmp_dir(); # dircopy() { my $rv = dircopy( "$tmpd/orig", "$tmpd/new" ); _is_deeply_path( "$tmpd/new", "$tmpd/orig", "dircopy() defaults as expected when target does not exist" ); mkdir "$tmpd/newnew"; my @dircopy_rv = dircopy( "$tmpd/orig", "$tmpd/newnew" ); _is_deeply_path( "$tmpd/newnew", "$tmpd/orig", "dircopy() defaults as expected when target does exist" ); $rv = dircopy( "$tmpd/orig/data", "$tmpd/new" ); ok( !$rv, "dircopy() returns false if source is not a directory" ); $rv = dircopy( "$tmpd/orig", "$tmpd/new/data" ); ok( !$rv, "dircopy() returns false if target is not a directory" ); } # dirmove() { my $rv = dirmove( "$tmpd/newnew", "$tmpd/moved" ); _is_deeply_path( "$tmpd/moved", "$tmpd/orig", "dirmove() defaults as expected when target does not exist" ); ok( !-d "$tmpd/newnew", "dirmove() removes source (when target does not exist)" ); mkdir "$tmpd/movedagain"; my @dirmove_rv = dirmove( "$tmpd/moved", "$tmpd/movedagain" ); _is_deeply_path( "$tmpd/movedagain", "$tmpd/orig", "dirmove() defaults as expected when target does exist" ); ok( !-d "$tmpd/moved", "dirmove() removes source (when target does exist)" ); $rv = dirmove( "$tmpd/orig/data", "$tmpd/new" ); ok( !$rv, "dirmove() returns false if source is not a directory" ); ok( -e "$tmpd/orig/data", "dirmove() does not delete source if source is not a directory" ); $rv = dirmove( "$tmpd/orig", "$tmpd/new/data" ); ok( !$rv, "dirmove() returns false if target is not a directory" ); ok( -e "$tmpd/orig", "dirmove() does not delete source if target is not a directory" ); } # fcopy() { # that fcopy copies files and symlinks is covered by the dircopy tests, specifically _is_deeply_path() my $rv = fcopy( "$tmpd/orig/data", "$tmpd/fcopy" ); is( path("$tmpd/orig/data")->slurp, path("$tmpd/fcopy")->slurp, "fcopy() defaults as expected when target does not exist" ); path("$tmpd/fcopyexisty")->spew("oh hai"); my @fcopy_rv = fcopy( "$tmpd/orig/data", "$tmpd/fcopyexisty" ); is( path("$tmpd/orig/data")->slurp, path("$tmpd/fcopyexisty")->slurp, "fcopy() defaults as expected when target does exist" ); $rv = fcopy( "$tmpd/orig", "$tmpd/fcopy" ); ok( !$rv, "fcopy() returns false if source is a directory" ); } # fmove() WiP { # that fmove copies files and symlinks is covered by the dirmove tests, specifically _is_deeply_path() path("$tmpd/data")->spew("oh hai"); my $rv = fmove( "$tmpd/data", "$tmpd/fmove" ); ok( $rv && !-e "$tmpd/data", "fmove() removes source file (target does not exist)" ); path("$tmpd/existy")->spew("42"); path("$tmpd/fmoveexisty")->spew("oh hai"); my @fmove_rv = fmove( "$tmpd/existy", "$tmpd/fmoveexisty" ); ok( $rv && !-e "$tmpd/existy", "fmove() removes source file (target does exist)" ); $rv = fmove( "$tmpd/orig", "$tmpd/fmove" ); ok( !$rv, "fmove() returns false if source is a directory" ); } # rcopy() { my $rv = rcopy( "$tmpd/orig/noexist", "$tmpd/rcopy/" ); ok !$rv, 'rcopy() returns false on non existant path'; no warnings "redefine"; my @dircopy_calls; my @fcopy_calls; local File::Copy::Recursive::dircopy = sub { push @dircopy_calls, [@_] }; local File::Copy::Recursive::fcopy = sub { push @fcopy_calls, [@_] }; File::Copy::Recursive::rcopy( "$tmpd/orig/", "$tmpd/rcopy/" ); is( @dircopy_calls, 1, 'rcopy() dispatches directory to dircopy()' ); File::Copy::Recursive::rcopy( "$tmpd/orig/", "$tmpd/rcopy/" ); is( @dircopy_calls, 2, 'rcopy() dispatches directory glob to dircopy()' ); File::Copy::Recursive::rcopy( "$tmpd/empty", "$tmpd/rcopy/" ); is( @fcopy_calls, 1, 'rcopy() dispatches empty file to fcopy()' ); File::Copy::Recursive::rcopy( "$tmpd/data", "$tmpd/rcopy/" ); is( @fcopy_calls, 2, 'rcopy() dispatches file (w/ trailing new line)to fcopy()' ); File::Copy::Recursive::rcopy( "$tmpd/data_tnl", "$tmpd/rcopy/" ); is( @fcopy_calls, 3, 'rcopy() dispatches file (w/ no trailing new line) to fcopy()' ); SKIP: { skip "symlink tests not applicable on systems w/ out symlink support ($^O)", 3 unless $File::Copy::Recursive::CopyLink; File::Copy::Recursive::rcopy( "$tmpd/symlink", "$tmpd/rcopy/" ); is( @fcopy_calls, 4, 'rcopy() dispatches symlink to fcopy()' ); File::Copy::Recursive::rcopy( "$tmpd/symlink-broken", "$tmpd/rcopy/" ); is( @fcopy_calls, 5, 'rcopy() dispatches broken symlink to fcopy()' ); File::Copy::Recursive::rcopy( "$tmpd/symlink-loopy", "$tmpd/rcopy/" ); is( @fcopy_calls, 6, 'rcopy() dispatches loopish symlink to fcopy()' ); } } # rmove() { my $rv = rmove( "$tmpd/orig/noexist", "$tmpd/rmove/" ); ok !$rv, 'rmove() returns false on non existant path'; no warnings "redefine"; my @dirmove_calls; my @fmove_calls; local File::Copy::Recursive::dirmove = sub { push @dirmove_calls, [@_] }; local File::Copy::Recursive::fcopy = sub { push @fmove_calls, [@_] }; File::Copy::Recursive::rmove( "$tmpd/orig/", "$tmpd/rmove/" ); is( @dirmove_calls, 1, 'rmove() dispatches directory to dirmove()' ); File::Copy::Recursive::rmove( "$tmpd/orig/", "$tmpd/rmove/" ); is( @dirmove_calls, 2, 'rmove() dispatches directory glob to dirmove()' ); File::Copy::Recursive::rmove( "$tmpd/empty", "$tmpd/rmove/" ); is( @fmove_calls, 1, 'rmove() dispatches empty file to fcopy()' ); File::Copy::Recursive::rmove( "$tmpd/data", "$tmpd/rmove/" ); is( @fmove_calls, 2, 'rmove() dispatches file (w/ trailing new line)to fcopy()' ); File::Copy::Recursive::rmove( "$tmpd/data_tnl", "$tmpd/rmove/" ); is( @fmove_calls, 3, 'rmove() dispatches file (w/ no trailing new line) to fcopy()' ); SKIP: { skip "symlink tests not applicable on systems w/ out symlink support ($^O)", 3 unless $File::Copy::Recursive::CopyLink; File::Copy::Recursive::rmove( "$tmpd/symlink", "$tmpd/rmove/" ); is( @fmove_calls, 4, 'rmove() dispatches symlink to fcopy()' ); File::Copy::Recursive::rmove( "$tmpd/symlink-broken", "$tmpd/rmove/" ); is( @fmove_calls, 5, 'rmove() dispatches broken symlink to fcopy()' ); File::Copy::Recursive::rmove( "$tmpd/symlink-loopy", "$tmpd/rmove/" ); is( @fmove_calls, 6, 'rmove() dispatches loopish symlink to fcopy()' ); } } # rcopy_glob() { my @rcopy_srcs; no warnings "redefine"; local File::Copy::Recursive::rcopy = sub { push @rcopy_srcs, $_[0] }; rcopy_glob( "$tmpd/orig/l", "$tmpd/rcopy_glob" ); is( @rcopy_srcs, $File::Copy::Recursive::CopyLink ? 4 : 1, "rcopy_glob() calls rcopy for each file in the glob" ); } # rmove_glob() { my @rmove_srcs; no warnings "redefine"; local File::Copy::Recursive::rmove = sub { push @rmove_srcs, $_[0] }; rmove_glob( "$tmpd/orig/l", "$tmpd/rmove_glob" ); is( @rmove_srcs, $File::Copy::Recursive::CopyLink ? 4 : 1, "rmove_glob() calls rmove for each file in the glob" ); } # pathempty() { ok( -e "$tmpd/new/data", "file exists" ); my $rv = pathempty("$tmpd/new"); is( $rv, 1, "correct return value for pathempty" ); ok( !-e "$tmpd/new/data", "file was removed" ); ok( -d "$tmpd/new", "directory still exists" ); } # pathrmdir() { my $rv = pathrmdir("$tmpd/orig"); is( $rv, 1, "correct return value for pathrmdir" ); ok( !-d "$tmpd/orig", "directory was removed" ); } # PATCHES WELCOME! # TODO: tests for sameness behavior and it use in all of these functions # TODO: @rv behavior in all of these functions # TODO: test for util functions; pathmk pathrm pathempty pathrmdir } note "functionality w/ 'value' globals"; { local $File::Copy::Recursive::DirPerms = 0751; my $tmpd = _get_fresh_tmp_dir(); mkdir( "$tmpd/what", 0777 ); File::Copy::Recursive::pathmk("$tmpd/what/what/what"); file_mode_isnt( "$tmpd/what", 0751, 'DirPerms in pathmk() does not effect existing dir' ); file_mode_is( "$tmpd/what/what", 0751, 'DirPerms in pathmk() effects initial new dir' ); file_mode_is( "$tmpd/what/what/what", 0751, 'DirPerms in pathmk() effects subsequent new dir' ); local $File::Copy::Recursive::KeepMode = 0; # overrides $DirPerms in dircopy() File::Copy::Recursive::dircopy( "$tmpd/orig", "$tmpd/new" ); for my $dir ( _get_dirs() ) { $dir =~ s/orig/new/; file_mode_is( "$tmpd/$dir", 0751, "DirPerms in dircopy() effects dir ($dir)" ); } } note "functionality w/ 'behavior' globals"; { { local $File::Copy::Recursive::CPRFComp = 1; my $tmpd = _get_fresh_tmp_dir(); File::Copy::Recursive::dircopy( "$tmpd/orig", "$tmpd/new" ); _is_deeply_path( "$tmpd/new", "$tmpd/orig", "CPRFComp being true effects dircopy() as expected when target does not exist" ); mkdir "$tmpd/existy"; File::Copy::Recursive::dircopy( "$tmpd/orig", "$tmpd/existy" ); _is_deeply_path( "$tmpd/existy/orig", "$tmpd/orig", "CPRFComp being true effects dircopy() as expected when target exists" ); File::Copy::Recursive::dircopy( "$tmpd/orig/", "$tmpd/newnew" ); _is_deeply_path( "$tmpd/newnew", "$tmpd/orig", "CPRFComp being true w/ glob path effects dircopy() as expected when target does not exist" ); mkdir "$tmpd/existify"; File::Copy::Recursive::dircopy( "$tmpd/orig/", "$tmpd/existify" ); _is_deeply_path( "$tmpd/existify", "$tmpd/orig", "CPRFComp being true w/ glob path effects dircopy() as expected when target exists" ); } { my $tmpd = _get_fresh_tmp_dir(); local $File::Copy::Recursive::RMTrgFil = 1; local $curr_unlink = sub { $! = 5; return; }; mkdir "$tmpd/derp"; path("$tmpd/derp/data")->spew("I exist therefor I am."); my @warnings = warnings { my $rv = File::Copy::Recursive::fcopy( "$tmpd/orig/data", "$tmpd/derp/data" ); ok( $rv, "fcopy() w/ \$RMTrgFil = 1 to file-returned true" ); }; cmp_deeply \@warnings, [ re(qr/RMTrgFil failed/) ], "fcopy() w/ \$RMTrgFil = 1 to file-warned"; @warnings = warnings { my $rv = File::Copy::Recursive::fcopy( "$tmpd/orig/data", "$tmpd/derp" ); ok( $rv, "fcopy() w/ \$RMTrgFil = 1 to dir-returned true" ); }; cmp_deeply \@warnings, [ re(qr/RMTrgFil failed/) ], "fcopy() w/ \$RMTrgFil = 1 to dir-warned"; } { my $tmpd = _get_fresh_tmp_dir(); local $File::Copy::Recursive::RMTrgFil = 2; local $curr_unlink = sub { $! = 5; return; }; mkdir "$tmpd/derp"; path("$tmpd/derp/data")->spew("I exist therefor I am."); my @warnings = warnings { my $rv = File::Copy::Recursive::fcopy( "$tmpd/orig/data", "$tmpd/derp/data" ); ok( !$rv, "fcopy() w/ \$RMTrgFil = 2 to file-returned false" ); }; cmp_deeply \@warnings, [], "fcopy() w/ \$RMTrgFil = 2 to file-no warning"; @warnings = warnings { my $rv = File::Copy::Recursive::fcopy( "$tmpd/orig/data", "$tmpd/derp" ); ok( !$rv, "fcopy() w/ \$RMTrgFil = 2 to dir-returned false" ); }; cmp_deeply \@warnings, [], "fcopy() w/ \$RMTrgFil = 2 to dir-no warning"; } # TODO (this is one reason why globals are not awesome :/) # $MaxDepth # $KeepMode # $CopyLink # $BdTrgWrn # $PFSCheck # $RemvBase # ForcePth # $NoFtlPth # $ForcePth # $CopyLoop # $RMTrgDir # $CondCopy # $BdTrgWrn # $SkipFlop } done_testing; ############### #### helpers ## ############### sub _get_dirs { return (qw(orig orig/foo orig/foo/bar orig/foo/baz orig/foo/bar/wop)); } sub _get_fresh_tmp_dir { my $tmpd = File::Temp->newdir; for my $dir ( _get_dirs() ) { mkdir "$tmpd/$dir" or die "Could not mkdir($tmpd/$dir) :$!\n"; path("$tmpd/$dir/empty")->spew(""); path("$tmpd/$dir/data")->spew("oh hai\n$tmpd/$dir"); path("$tmpd/$dir/data_tnl")->spew("oh hai\n$tmpd/$dir\n"); if ($File::Copy::Recursive::CopyLink) { symlink( "data", "$tmpd/$dir/symlink" ); symlink( "noexist", "$tmpd/$dir/symlink-broken" ); symlink( "..", "$tmpd/$dir/symlink-loopy" ); } } return $tmpd; } sub _is_deeply_path { my ( $got_dir, $expected_dir, $test_name ) = @_; my $got_tree_hr = _get_tree_hr($got_dir); my $expected_tree_hr = _get_tree_hr($expected_dir); is_deeply( $got_tree_hr, $expected_tree_hr, $test_name ); for my $path ( sort keys %{$got_tree_hr} ) { if ( $got_tree_hr->{$path} eq "symlink" ) { is( readlink("$got_dir/$path"), readlink("$expected_dir/$path"), " - symlink target preserved (…$path)" ); } elsif ( $got_tree_hr->{$path} eq "file" ) { is( path("$got_dir/$path")->slurp, path("$expected_dir/$path")->slurp, " - file contents preserved (…$path)" ); } } } sub _get_tree_hr { my ($dir) = @_; return if !-d $dir; my %tree; my $fetch = path($dir)->iterator; $dir =~ s#\\#\/#g if $^O eq 'MSWin32'; #->iterator returns paths with '/' while ( my $next_path = $fetch->() ) { my $normalized_next_path = $next_path; $normalized_next_path =~ s/\Q$dir\E//; $tree{$normalized_next_path} = -l $next_path ? "symlink" : -f $next_path ? "file" : -d $next_path ? "directory" : "¯\_(ツ)_/¯"; } return \%tree; } ��02.legacy-symtogsafe.t��0000644��00000011053�15125143331�0010572 0��ustar�00��use strict; use warnings; use Test::More; use Test::Fatal; use File::Copy::Recursive qw(pathempty pathrm pathrmdir); if ( !$File::Copy::Recursive::CopyLink ) { plan skip_all => "symlink tests not applicable on systems w/ out symlink support ($^O)"; } elsif ( !-x "/bin/mv" \|\| !-x "/bin/mkdir" ) { # dragons! patches welcome plan skip_all => 'Only operate on systems w/ /bin/mv and /bin/mkdir, for reasons see the cource code comments'; } else { plan tests => 33; } use File::Temp; use Cwd; use File::Spec; my $orig_dir = Cwd::cwd(); my $dir = File::Temp->newdir(); our $catdir_toggle = sub { }; our @catdir_calls; chdir $dir \|\| die "Could not chdir into temp directory: $!\n"; # so we can pathrm(), dragons! { ############################################################################## #### Wrap catdir() to control a symlink toggle in the path traversal loops. ## ############################################################################## no strict "refs"; no warnings "redefine", "once"; my $real_catdir = \&{ $File::Spec::ISA[0] . "::catdir" }; local File::Spec::catdir = sub { my ( $self, @args ) = @_; push @catdir_calls, \@args; $catdir_toggle->(@args); goto &$real_catdir; }; mkdir "pathempty"; mkdir "pathempty/sanity"; pathempty("pathempty"); is( @catdir_calls, 1, "sanity check: catdir was actually called in the pathempty() loop" ); mkdir "pathrmdir"; mkdir "pathrmdir/sanity"; pathrmdir("$dir/pathrmdir"); is( @catdir_calls, 2, "sanity check: catdir was actually called in the pathrmdir() loop" ); mkdir "pathrm"; mkdir "pathrm/sanity"; pathrm("pathrm"); is( @catdir_calls, 3, "sanity check: catdir was actually called in the pathrm() loop" ); #################### #### Actual tests ## #################### for my $func (qw(pathrm pathempty pathrmdir)) { _test( $func, "cwd/foo/bar/baz", "bails when high level changes" ); _test( $func, "cwd/foo/bar", "bails when mid level changes" ); _test( $func, "cwd/foo", "bails when low level changes" ); _test( $func, "cwd", "bails when CWD level changes" ); _test( $func, "", "bails when below level changes" ); } } chdir $orig_dir \|\| die "Could not chdir back to original directory: $!\n"; ############### #### helpers ## ############### sub _test { my ( $func, $toggle, $label ) = @_; _setup_tree($func); { local @catdir_calls = (); local $catdir_toggle = sub { return if $func eq 'pathrm' && @catdir_calls < 3; # let it do its first round, this mockage is gross … chdir $dir \|\| die "could not toggle dir/symlink (chdir): $!"; my $parent = ""; if ($toggle) { $parent = $toggle; $parent =~ s{[^/]+$}{}; # use system call since the perl to do this will likely use File::Spec system("/bin/mkdir -p moved/$func/$parent") and die "could not toggle dir/symlink (mkdir): $?\n"; } # use system call since the perl to do this will likely use File::Spec system("/bin/mv $dir/$func/$toggle $dir/moved/$func/$toggle") and die "could not toggle dir/symlink (mv): $?\n"; symlink( "$dir/victim", "$dir/$func" . ( $toggle ? "/$toggle" : "" ) ) or die "could not toggle dir/symlink (sym): $!\n"; chdir "$func/cwd" \|\| die "could not toggle dir/symlink (back into $func/cwd): $!\n"; }; like exception { no strict "refs"; $func->("foo/bar/baz") }, qr/directory . changed: expected dev=.* ino=., actual dev=. ino=., aborting/, "$func() detected symlink toggle: $label"; is( @catdir_calls, $func eq 'pathrm' ? 3 : 1, "sanity check: catdir was actually called in $func() ($label)" ); } _teardown_tree($func); } sub _teardown_tree { my ($base) = @_; chdir $dir \|\| die "Could not chdir back into temp dir: $!\n"; pathrmdir($base); pathrmdir("moved/"); pathrmdir("victim/"); return; } sub _setup_tree { my ($base) = @_; for my $dir ( "moved", "victim", "victim/cwd", $base, "$base/cwd", "$base/cwd/foo", "$base/cwd/foo/bar", "$base/cwd/foo/bar/baz" ) { mkdir $dir \|\| die "Could not make test tree ($dir): $!\n"; open my $fh, ">", "$dir/file.txt" \|\| die "Could not make test file in ($dir): $!\n"; print {$fh} "oh hai\n"; close($fh); } chdir "$base/cwd" \|\| die "Could not chdir into $base/cwd: $!\n"; return; } ��00.load.t��0000644��00000000105�15125143331�0006060 0��ustar�00��use Test::More tests => 1; BEGIN { use_ok('File::Copy::Recursive') } ��04.readonly-dir.t��0000644��00000001722�15125143331�0007544 0��ustar�00��use strict; use warnings; use Test::More 0.88; use Test::Warnings 'warnings'; use Test::Deep; use File::Temp; use Path::Tiny; use File::Copy::Recursive 'dircopy'; if ( $^O eq 'MSWin32' ) { plan skip_all => "test uses chmod which may or may not do what we want here, patches welcome!"; } my $dir = File::Temp->newdir; for my $pth (qw(src/ src/top src/top/sub1 src/top/sub2)) { mkdir "$dir/$pth"; } path("$dir/src/top/sub1/file1.2")->spew("hello-1.2"); path("$dir/src/top/sub2/file2.2")->spew("hello-2.2"); path("$dir/src/top/sub2/file2.1")->spew(""); `chmod -w $dir/src/top/sub2`; SKIP: { skip "test read only", 3, if -w "$dir/src/top/sub2"; my @warnings = warnings { dircopy( "$dir/src", "$dir/dest" ) }; is( scalar( path("$dir/src/top/sub2")->children ), 2, "readonly direct0ry contents are copied" ); is( scalar( path("$dir/src/top/sub1")->children ), 1, "writable directory contents are copied" ); } `chmod +w $dir/src/top/sub2`; done_testing; ��05.legacy-pathmk_unc.t��0000644��00000004536�15125143331�0010555 0��ustar�00��use strict; use warnings; use Cwd; use File::Copy::Recursive qw(pathmk pathempty); use File::Temp (); use Path::Tiny; use Test::More; if ( $^O ne 'MSWin32' ) { plan skip_all => 'Test irrelevant on non-windows OSs'; } else { plan tests => 6; } diag("Testing legacy File::Copy::Recursive::pathmk() $File::Copy::Recursive::VERSION"); is( _translate_to_unc('C:/foo/bar.txt'), '//127.0.0.1/C$/foo/bar.txt', 'sanity check: _translate_to_unc w/ /' ); is( _translate_to_unc('C:\\foo\\bar.txt'), '\\\\127.0.0.1\\C$\\foo\\bar.txt', 'sanity check: _translate_to_unc w/ \\' ); my $tempdir = File::Temp->newdir(); my @members = _all_files_in($tempdir); is_deeply( \@members, [], 'sanity check: created empty temp dir' ); pathmk("$tempdir\\foo\\bar\\baz"); # create regular path @members = _all_files_in($tempdir); ok( -d "$tempdir\\foo\\bar\\baz", "pathmk(regular path) creates path" ); pathempty($tempdir); @members = _all_files_in($tempdir); is_deeply( \@members, [], 'sanity check: temp dir empty again' ); my $uncpath = _translate_to_unc($tempdir); pathmk("$uncpath\\foo\\bar\\baz"); # create UNC path @members = _all_files_in($tempdir); ok( -d "$tempdir\\foo\\bar\\baz", "pathmk(unc path) creates path" ); ############### #### helpers ## ############### sub _all_files_in { my $dir = shift; my $state = path($dir)->visit( sub { my ( $path, $state ) = @_; push @{ $state->{files} }, $path; }, { recurse => 1 }, ); return map { "$_" } @{ $state->{files} \|\| [] }; } sub _translate_to_unc { my ($path) = @_; die "Should be called on Windows only!" unless $^O eq 'MSWin32'; if ( $path =~ m\|^\w:([/\\])\| ) { # an absolute path with a Windows-style drive letter my $sep = $1; # C:\path\foo.txt corresponds to \\127.0.0.1\C$\path\foo.txt (if \ # is regarded as a regular character, not an escape character). # Prefix UNC part, using path separator from original $path =~ s\|^(\w):\|$sep${sep}127.0.0.1${sep}$1\$\|; } else { # a relative path my ($sep) = $path =~ m\|([\\/])\|; # locate path separator $sep \|\|= '\\'; # default to backslash $path = translate_to_unc( Cwd::getcwd() . $sep . $path ); # assumes that Cwd::getcwd() returns a path with a drive letter! } $path; } ��01-api-format.t��0000644��00000021347�15125143403�0007213 0��ustar�00��#!/usr/bin/perl use strict; use warnings; use Test::More; # last test to print use lib 't/lib'; use PubApiTest (); my $pubapi = PubApiTest->new( 'ip' => '127.0.0.1', 'usessl' => 1, 'user' => 'someuser', 'pass' => 'somepass', 'error_log' => '/dev/null', ); # test WHM $PubApiTest::test_config = { 'service' => 'whostmgr', 'uri' => '/json-api/loadavg', 'method' => 'POST', 'call' => 'whm_api-noform', 'return_format' => 'json', }; my $res = $pubapi->whm_api('loadavg'); is( ref $res, 'HASH', 'Returned format ok for ' . $PubApiTest::test_config->{'call'} ); $PubApiTest::test_config->{'test_formdata'} = 'hash'; $PubApiTest::test_config->{'formdata'} = { 'key' => 'value', 'api.version' => 1 }; $PubApiTest::test_config->{'call'} = 'whm_api-refform'; $res = $pubapi->whm_api( 'loadavg', { 'key' => 'value' } ); is( ref $res, 'HASH', 'Returned format ok for ' . $PubApiTest::test_config->{'call'} ); $PubApiTest::test_config->{'test_formdata'} = 'hash'; $PubApiTest::test_config->{'formdata'} = { 'key' => 'value', 'api.version' => 0 }; $PubApiTest::test_config->{'call'} = 'whm_api-refapi0'; $res = $pubapi->whm_api( 'loadavg', $PubApiTest::test_config->{'formdata'} ); is( ref $res, 'HASH', 'Returned format ok for ' . $PubApiTest::test_config->{'call'} ); $PubApiTest::test_config->{'test_formdata'} = 'hash'; $PubApiTest::test_config->{'formdata'} = { 'key' => 'value', 'api.version' => 1 }; $PubApiTest::test_config->{'call'} = 'whm_api-refapi1'; $res = $pubapi->whm_api( 'loadavg', $PubApiTest::test_config->{'formdata'} ); is( ref $res, 'HASH', 'Returned format ok for ' . $PubApiTest::test_config->{'call'} ); $PubApiTest::test_config->{'test_formdata'} = 'string'; $PubApiTest::test_config->{'formdata'} = 'api.version=1&one&two'; $PubApiTest::test_config->{'call'} = 'whm_api-stringform'; $res = $pubapi->whm_api( 'loadavg', 'one&two' ); is( ref $res, 'HASH', 'Returned format ok for ' . $PubApiTest::test_config->{'call'} ); $PubApiTest::test_config->{'test_formdata'} = 'string'; $PubApiTest::test_config->{'formdata'} = 'api.version=0&one&two'; $PubApiTest::test_config->{'call'} = 'whm_api-stringapi0'; $res = $pubapi->whm_api( 'loadavg', 'api.version=0&one&two' ); is( ref $res, 'HASH', 'Returned format ok for ' . $PubApiTest::test_config->{'call'} ); delete $PubApiTest::test_config->{'formdata'}; delete $PubApiTest::test_config->{'test_formdata'}; $PubApiTest::test_config->{'return_format'} = 'json'; $res = $pubapi->whm_api( 'loadavg', undef, 'json' ); is( $res, '{"something":"somethinglese"}', 'raw JSON data returned raw correctly from whm_api' ); $PubApiTest::test_config->{'test_format'} = 'xml'; $PubApiTest::test_config->{'return_format'} = 'xml'; $PubApiTest::test_config->{'uri'} = '/xml-api/loadavg'; $res = $pubapi->whm_api( 'loadavg', undef, 'xml' ); is( $res, '<node><something>somethingelse</something></node>', 'raw XML data returned raw correctly from whm_api' ); # test API1 $PubApiTest::test_config = { 'service' => 'cpanel', 'uri' => '/json-api/cpanel', 'method' => 'GET', 'call' => 'api1-noargs', 'return_format' => 'json', 'test_formdata' => 'hash', }; # Without arguments $PubApiTest::test_config->{'formdata'} = { 'cpanel_jsonapi_module' => 'Test', 'cpanel_jsonapi_func' => 'test', 'cpanel_jsonapi_apiversion' => 1, }; my $call_config = { 'module' => 'Test', 'func' => 'test', }; $res = $pubapi->cpanel_api1_request( 'cpanel', $call_config ); is( ref $res, 'HASH', 'Returned format ok for ' . $PubApiTest::test_config->{'call'} ); # with arguments $PubApiTest::test_config->{'call'} = 'api1-args'; $PubApiTest::test_config->{'formdata'}->{'arg-0'} = 'one'; $PubApiTest::test_config->{'formdata'}->{'arg-1'} = 'two'; $res = $pubapi->cpanel_api1_request( 'cpanel', $call_config, [ 'one', 'two' ] ); is( ref $res, 'HASH', 'Returned format ok for ' . $PubApiTest::test_config->{'call'} ); # WHM # with arguments $PubApiTest::test_config->{'call'} = 'whm-api1-args'; $PubApiTest::test_config->{'formdata'}->{'cpanel_jsonapi_user'} = 'someuser'; $PubApiTest::test_config->{'service'} = 'whostmgr'; $call_config->{'user'} = 'someuser'; $res = $pubapi->cpanel_api1_request( 'whostmgr', $call_config, [ 'one', 'two' ] ); is( ref $res, 'HASH', 'Returned format ok for ' . $PubApiTest::test_config->{'call'} ); # without arguments $PubApiTest::test_config->{'call'} = 'whm-api1-noargs'; delete $PubApiTest::test_config->{'formdata'}->{'arg-1'}; delete $PubApiTest::test_config->{'formdata'}->{'arg-0'}; $res = $pubapi->cpanel_api1_request( 'whostmgr', $call_config ); is( ref $res, 'HASH', 'Returned format ok for ' . $PubApiTest::test_config->{'call'} ); # Test JSON $PubApiTest::test_config->{'call'} = 'whm-api1-rawjson'; $PubApiTest::test_config->{'return_format'} = 'json'; $res = $pubapi->cpanel_api1_request( 'whostmgr', $call_config, undef, 'json' ); is( $res, '{"something":"somethinglese"}', 'raw JSON data returned raw correctly from cpanel_api1_request' ); # Test XML $PubApiTest::test_config->{'call'} = 'whm-api1-rawxml'; $PubApiTest::test_config->{'test_format'} = 'xml'; $PubApiTest::test_config->{'return_format'} = 'xml'; $PubApiTest::test_config->{'uri'} = '/xml-api/cpanel'; $PubApiTest::test_config->{'formdata'} = { 'cpanel_xmlapi_user' => 'someuser', 'cpanel_xmlapi_module' => 'Test', 'cpanel_xmlapi_func' => 'test', 'cpanel_xmlapi_apiversion' => '1', }; $res = $pubapi->cpanel_api1_request( 'whostmgr', $call_config, [], 'xml' ); is( $res, '<node><something>somethingelse</something></node>', 'raw XML data returned raw correctly from cpanel_api1_request' ); # API2 $PubApiTest::test_config = { 'service' => 'cpanel', 'uri' => '/json-api/cpanel', 'method' => 'GET', 'call' => 'api2-noargs', 'return_format' => 'json', 'test_formdata' => 'hash', }; $PubApiTest::test_config->{'formdata'} = { 'cpanel_jsonapi_func' => 'test', 'cpanel_jsonapi_module' => 'Api2Test', 'cpanel_jsonapi_apiversion' => '2', }; $call_config = { 'module' => 'Api2Test', 'func' => 'test', }; # without args $res = $pubapi->cpanel_api2_request( 'cpanel', $call_config ); is( ref $res, 'HASH', 'Returned format ok for ' . $PubApiTest::test_config->{'call'} ); # with args $PubApiTest::test_config->{'call'} = 'whm-api2-args'; my $args = { 'testing' => 'one two three', 'earth below' => 'us', }; foreach my $key ( keys %{$args} ) { $PubApiTest::test_config->{'formdata'}->{$key} = $args->{$key}; } $res = $pubapi->cpanel_api2_request( 'cpanel', $call_config, $args ); is( ref $res, 'HASH', 'Returned format ok for ' . $PubApiTest::test_config->{'call'} ); # XML/JSON response tests delete $PubApiTest::test_config->{'formdata'}->{'testing'}; delete $PubApiTest::test_config->{'formdata'}->{'earth below'}; $PubApiTest::test_config->{'call'} = 'api2-rawjson'; $res = $pubapi->cpanel_api2_request( 'cpanel', $call_config, undef, 'json' ); is( $res, '{"something":"somethinglese"}', 'raw JSON data returned raw correctly from cpanel_api2_request' ); #xml $PubApiTest::test_config->{'call'} = 'api2-rawxml'; $PubApiTest::test_config->{'formdata'} = { 'cpanel_xmlapi_module' => 'Api2Test', 'cpanel_xmlapi_func' => 'test', 'cpanel_xmlapi_apiversion' => '2' }; $PubApiTest::test_config->{'format'} = 'xml'; $PubApiTest::test_config->{'return_format'} = 'xml'; $PubApiTest::test_config->{'uri'} = '/xml-api/cpanel'; $res = $pubapi->cpanel_api2_request( 'cpanel', $call_config, undef, 'xml' ); is( $res, '<node><something>somethingelse</something></node>', 'raw XML data returned raw correctly from cpanel_api2_request' ); # test call failure situations $PubApiTest::test_config->{'badcall'} = 'whmapi'; $pubapi->whm_api('version'); like( $pubapi->{'error'}, qr/cPanel::PublicAPI::whm_api was called with the invalid API call of/, 'whm_api invalid call checking works' ); $PubApiTest::test_config->{'badcall'} = 'cpanelapi1'; $pubapi->cpanel_api1_request( 'cpanel', { 'module' => 'test', 'func' => 'test' } ); like( $pubapi->{'error'}, qr/cPanel::PublicAPI::cpanel_api1_request was called with the invalid API1 call of:/, 'cpanel_api1_request invalid call checking works' ); $PubApiTest::test_config->{'badcall'} = 'cpanelapi2'; $pubapi->cpanel_api2_request( 'cpanel', { 'module' => 'test', 'func' => 'test' } ); like( $pubapi->{'error'}, qr/cPanel::PublicAPI::cpanel_api2_request was called with the invalid API2 call of:/, 'cpanel_api1_request invalid call checking works' ); done_testing(); ��05-api-query_tokens.t��0000644��00000010451�15125143403�0010451 0��ustar�00��#!/usr/bin/perl # Copyright 2017, cPanel, Inc. # All rights reserved. # http://cpanel.net # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright notice, # this list of conditions and the following disclaimer in the documentation # and/or other materials provided with the distribution. # # 3. Neither the name of the owner nor the names of its contributors may be # used to endorse or promote products derived from this software without # specific prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED # WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE # DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. use strict; use warnings; use Test::More; # last test to print use cPanel::PublicAPI (); my @getpwuid = getpwuid($>); my $homedir = $getpwuid[7]; my $user = $getpwuid[0]; if ( !-d '/usr/local/cpanel' ) { plan skip_all => 'This test requires that cPanel and WHM are installed on a server'; } if ( !-e $homedir . '/.accesshash' ) { plan skip_all => 'This test requires that an account hash is defined (see "Setup Remote Access Keys" in WHM)'; } check_cpanel_version(63) or plan skip_all => 'This test requires cPanel version 64 or higher'; my $pubapi = cPanel::PublicAPI->new( 'ssl_verify_mode' => 0 ); if ( !-e '/var/cpanel/users/papiunit' ) { plan tests => 5; my $password = generate_password(); my $res = $pubapi->whm_api( 'createacct', { 'username' => 'papiunit', 'password' => $password, 'domain' => 'cpanel-public-api-test.acct', 'reseller' => 1, } ); like( $res->{'metadata'}->{'reason'}, qr/Account Creation Ok/, 'Test account created' ); _test_api_token_as_reseller( 'papiunit', $password ); $res = $pubapi->whm_api( 'removeacct', { 'user' => 'papiunit', } ); like( $res->{'metadata'}->{'reason'}, qr/papiunit account removed/, 'Test Account Removed' ); } else { plan skip_all => 'Unable to create test account. It already exists'; } sub _test_api_token_as_reseller { my ( $reseller, $password ) = @_; # Create the API Token my $reseller_api = cPanel::PublicAPI->new( 'user' => $reseller, 'pass' => $password, 'ssl_verify_mode' => 0 ); my $res = $reseller_api->whm_api( 'api_token_create', { 'token_name' => 'my_token' } ); ok( $res->{'metadata'}->{'result'}, 'Successfully called api_token_create API call as reseller' ); my $plaintext_token = $res->{'data'}->{'token'}; my $pub_api_with_token = cPanel::PublicAPI->new( 'user' => $reseller, 'api_token' => 'this is so wrong', 'ssl_verify_mode' => 0 ); eval { $pub_api_with_token->whm_api('loadavg') }; ok( $@, 'API call fails with wrong API token' ); $pub_api_with_token->api_token($plaintext_token); $res = $pub_api_with_token->whm_api('loadavg'); ok( defined $res->{'one'}, 'API call successfully made using the correct token' ); } sub generate_password { my @chars = ( 'A' .. 'Z', 'a' .. 'z', '0' .. '9' ); my $pass = ''; foreach ( 1 .. 32 ) { $pass .= $chars[ int rand @chars ]; } return $pass; } sub check_cpanel_version { my $min_version = shift; open( my $version_fh, '<', '/usr/local/cpanel/version' ) \|\| return 0; my $version = do { local $/; <$version_fh> }; chomp $version; my ( $maj, $min, $rev, $sup ) = split /[\._]/, $version; return 1 if $min >= $min_version; return 0; } ��check-changes.t��0000644��00000000420�15125143403�0007406 0��ustar�00��#!/usr/bin/env perl use Test::More; plan skip_all => 'Release tests not required for installation' if not $ENV{RELEASE_TESTING}; eval { require Test::CheckChanges }; plan skip_all => 'Test::CheckChanges required for this test' if $@; Test::CheckChanges::ok_changes(); ��02-construct.t��0000755��00000016516�15125143403�0007206 0��ustar�00��#!/usr/bin/perl # Copyright 2017, cPanel, Inc. # All rights reserved. # http://cpanel.net # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright notice, # this list of conditions and the following disclaimer in the documentation # and/or other materials provided with the distribution. # # 3. Neither the name of the owner nor the names of its contributors may be # used to endorse or promote products derived from this software without # specific prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED # WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE # DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. use strict; use warnings; use Test::More; use Test::Exception; use cPanel::PublicAPI (); my @getpwuid = getpwuid($>); my $homedir = $getpwuid[7]; my $user = $getpwuid[0]; # test default settings if ( !-e $homedir . '/.accesshash' ) { $ENV{'REMOTE_PASSWORD'} = 'b4r!' if !defined $ENV{'REMOTE_PASSWORD'}; $ENV{'SERVER_SOFTWARE'} = 'cpsrvd fakeout'; } check_options(); check_options( 'debug' => 1, 'error_log' => '/dev/null' ); check_options( 'timeout' => 150 ); check_options( 'usessl' => 0 ); check_options( 'ip' => '4.2.2.2' ); check_options( 'host' => 'zomg.cpanel.net' ); check_options( 'error_log' => '/dev/null' ); check_options( 'user' => 'bar' ); check_options( 'pass' => 'f00!3Df@' ); my $accesshash = 'sdflkjl sdafjkl sdlfkjh'; check_options( 'accesshash' => $accesshash ); check_options( 'api_token' => 'sdfkjl' ); throws_ok { check_options( 'api_token' => 'sdfkjl', 'accesshash' => $accesshash ); } qr/You cannot specify both an accesshash and an API token/, 'Dies when specifying both an accesshash and API token'; my $http_tiny_creator_called; my $pubapi = cPanel::PublicAPI->new( 'error_log' => '/dev/null', http_tiny_creator => sub { $http_tiny_creator_called = 1; return HTTP::Tiny->new(@_); }, ); ok( $http_tiny_creator_called, 'http_tiny_creator is called' ); $pubapi->error('random string'); is( $pubapi->{'error'}, 'random string', 'Error variable is stored correctly' ); $pubapi->_init(); is( ref $cPanel::PublicAPI::CFG{'uri_encoder_func'}, 'CODE', 'URI Encoder Detected' ); $pubapi->_init_serializer(); is( ref $cPanel::PublicAPI::CFG{'api_decode_func'}, 'CODE', 'Serializer parse function detected' ); like( $cPanel::PublicAPI::CFG{'serializer_module'}, qr/^JSON/, 'Serializer Module is Named' ); is( $cPanel::PublicAPI::CFG{'serializer'}, 'json', 'Serailizer format is correct' ); my $query_result = $pubapi->format_http_query( { 'one' => 'uno', 'two' => 'dos' } ); is( $query_result, 'one=uno&two=dos', 'format_http_query' ); $pubapi->set_debug(1); is( $pubapi->{'debug'}, 1, 'set_debug accessor' ); $pubapi->user('someuser'); is( $pubapi->{'user'}, 'someuser', 'user accessor' ); $pubapi->{'accesshash'} = 'deleteme'; $pubapi->pass('somepass'); is( $pubapi->{'pass'}, 'somepass', 'pass accessor' ); ok( !exists $pubapi->{'accesshash'}, 'pass accessor deletes accesshash scalar' ); $pubapi->accesshash('onetwothreefour'); is( $pubapi->{'accesshash'}, 'onetwothreefour', 'accesshash accessor' ); ok( !exists $pubapi->{'pass'}, 'accesshash accessor deletes pass scalar' ); $pubapi->api_token('fivesixseveneight'); is( $pubapi->{'accesshash'}, 'fivesixseveneight', 'api_token accessor' ); ok( !exists $pubapi->{'pass'}, 'api_token accessor deletes pass scalar' ); my $header_string = $pubapi->format_http_headers( { 'Authorization' => 'Basic cm9vdDpsMGx1cnNtNHJ0IQ==' } ); is( $header_string, "Authorization: Basic cm9vdDpsMGx1cnNtNHJ0IQ==\r\n", 'format_http_headers is ok' ); can_ok( $pubapi, 'new', 'set_debug', 'user', 'pass', 'accesshash', 'api_token', 'whm_api', 'api_request', 'cpanel_api1_request', 'cpanel_api2_request', '_total_form_length', '_init_serializer', '_init', 'error', 'debug', 'format_http_query' ); done_testing(); # This subroutine is intended to check the options sent to a publicAPI instance. # The first parameter is the publicAPI instance, the rest should be hash key-pairs that allow you to # override default settings sub check_options { my %OPTS = @_; my $pubapi = cPanel::PublicAPI->new(%OPTS); isa_ok( $pubapi, 'cPanel::PublicAPI' ); if ( defined $OPTS{'debug'} ) { is( $pubapi->{'debug'}, $OPTS{'debug'}, 'debug constructor option' ); } else { is( $pubapi->{'debug'}, '0', 'debug default' ); } if ( defined $OPTS{'timeout'} ) { is( $pubapi->{'timeout'}, $OPTS{'timeout'}, 'timeout constructor option' ); } else { is( $pubapi->{'timeout'}, 300, 'timeout default' ); } if ( defined $OPTS{'usessl'} ) { is( $pubapi->{'usessl'}, $OPTS{'usessl'}, 'usessl constructor option' ); } else { is( $pubapi->{'usessl'}, 1, 'usessl default' ); } if ( defined $OPTS{'ip'} ) { is( $pubapi->{'ip'}, $OPTS{'ip'}, 'ip constructor option' ); } elsif ( defined $OPTS{'host'} ) { is( $pubapi->{'host'}, $OPTS{'host'}, 'host constructor option' ); } else { is( $pubapi->{'ip'}, '127.0.0.1', 'ip default' ); } if ( defined $OPTS{'error_log'} ) { ok( $pubapi->{'error_fh'} ne \STDERR, 'error_log is not STDERR' ); } else { is( $pubapi->{'error_fh'}, \STDERR, 'error_log is set to STDERR' ); } if ( defined $OPTS{'user'} ) { is( $pubapi->{'user'}, $OPTS{'user'}, 'user constructor option' ); } else { is( $pubapi->{'user'}, $user, 'user default' ); } if ( defined $OPTS{'pass'} ) { is( $pubapi->{'pass'}, $OPTS{'pass'}, 'pass constructor option' ); } elsif ( defined $OPTS{'api_token'} ) { is( $pubapi->{'accesshash'}, $OPTS{'api_token'}, 'api_token constructor option' ); } elsif ( defined $OPTS{'accesshash'} ) { my $accesshash = $OPTS{'accesshash'}; $accesshash =~ s/[\r\n]//g; is( $pubapi->{'accesshash'}, $accesshash, 'accesshash constructor option' ); } else { if ( -e $homedir . './accesshash' ) { my $accesshash = get_accesshash(); is( $pubapi->{'accesshash'}, $accesshash, 'accesshash default' ); } else { is( $pubapi->{'pass'}, $ENV{'REMOTE_PASSWORD'}, 'password default' ); } } } sub get_accesshash { my $accesshash; open( my $ah_fh, '<', $homedir . '/.accesshash' ); foreach my $line ( readline($ah_fh) ) { $accesshash .= $line; } $accesshash =~ s/[\r\n]//; return $accesshash; } ��04-tfa-sessions.t��0000644��00000014450�15125143403�0007572 0��ustar�00��#!/usr/bin/perl # Copyright 2017, cPanel, Inc. # All rights reserved. # http://cpanel.net # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # # 1. Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright notice, # this list of conditions and the following disclaimer in the documentation # and/or other materials provided with the distribution. # # 3. Neither the name of the owner nor the names of its contributors may be # used to endorse or promote products derived from this software without # specific prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED # WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE # DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. use strict; use warnings; use Test::More; # last test to print use cPanel::PublicAPI (); my @getpwuid = getpwuid($>); my $homedir = $getpwuid[7]; my $user = $getpwuid[0]; if ( !-d '/usr/local/cpanel' ) { plan skip_all => 'This test requires that cPanel and WHM are installed on a server'; } if ( !-e $homedir . '/.accesshash' ) { plan skip_all => 'This test requires that an account hash is defined (see "Setup Remote Access Keys" in WHM)'; } check_cpanel_version() or plan skip_all => 'This test requires cPanel version 54 or higher'; eval { require MIME::Base32; require Digest::SHA; 1; } or do { plan skip_all => 'This test requires the MIME::Base32 and Digest::SHA modules'; }; unshift @INC, '/usr/local/cpanel'; require Cpanel::Security::Authn::TwoFactorAuth::Google; my $pubapi = check_api_access_and_config(); if ( !-e '/var/cpanel/users/papiunit' ) { my $password = generate_password(); my $res = $pubapi->whm_api( 'createacct', { 'username' => 'papiunit', 'password' => $password, 'domain' => 'cpanel-public-api-test.acct', 'reseller' => 1, } ); like( $res->{'metadata'}->{'reason'}, qr/Account Creation Ok/, 'Test account created' ); $res = $pubapi->whm_api( 'setacls', { 'reseller' => 'papiunit', 'acl-create-acct' => 1, } ); ok( $res->{'metadata'}->{'result'}, 'Assigned create-acct ACL successfully' ); _test_tfa_as_reseller( 'papiunit', $password ); $res = $pubapi->whm_api( 'removeacct', { 'user' => 'papiunit', } ); like( $res->{'metadata'}->{'reason'}, qr/papiunit account removed/, 'Test Account Removed' ); } else { plan skip_all => 'Unable to create test account. It already exists'; } done_testing(); sub _test_tfa_as_reseller { my ( $reseller, $password ) = @_; my $reseller_api = cPanel::PublicAPI->new( 'user' => $reseller, 'pass' => $password, 'ssl_verify_mode' => 0 ); my $res = $reseller_api->whm_api( 'twofactorauth_generate_tfa_config', {} ); ok( $res->{'metadata'}->{'result'}, 'Successfully called generate tfa config API call as reseller' ); my $tfa_secret = $res->{'data'}->{'secret'}; my $google_auth = Cpanel::Security::Authn::TwoFactorAuth::Google->new( { 'secret' => $tfa_secret, 'account_name' => '', 'issuer' => '' } ); $res = $reseller_api->whm_api( 'twofactorauth_set_tfa_config', { 'secret' => $tfa_secret, 'tfa_token' => $google_auth->generate_code(), } ); ok( $res->{'metadata'}->{'result'}, '2FA successfully configured for reseller' ); eval { $reseller_api->whm_api('loadavg') }; ok( $@, 'API calls fail without a 2FA session established' ); $reseller_api->establish_tfa_session( 'whostmgr', $google_auth->generate_code() ); $res = $reseller_api->whm_api('loadavg'); ok( defined $res->{'one'}, 'API call successfully made after establishing 2FA session' ); } sub generate_password { my @chars = ( 'A' .. 'Z', 'a' .. 'z', '0' .. '9' ); my $pass = ''; foreach ( 1 .. 32 ) { $pass .= $chars[ int rand @chars ]; } return $pass; } sub check_cpanel_version { open( my $version_fh, '<', '/usr/local/cpanel/version' ) \|\| return 0; my $version = do { local $/; <$version_fh> }; chomp $version; my ( $maj, $min, $rev, $sup ) = split /[\._]/, $version; return 1 if $min >= 53; return 0; } sub check_api_access_and_config { open( my $config_fh, '<', '/var/cpanel/cpanel.config' ) \|\| BAIL_OUT('Could not load /var/cpanel/cpanel.config'); my $securitypolicy_enabled = 0; my $securitypolicy_xml_api_enabled = 0; while ( my $line = readline($config_fh) ) { next if $line !~ /=/; chomp $line; my ( $key, $value ) = split( /=/, $line, 2 ); if ( $key eq 'SecurityPolicy::TwoFactorAuth' ) { $securitypolicy_enabled = 1 if $value; } elsif ( $key eq 'SecurityPolicy::xml-api' ) { $securitypolicy_xml_api_enabled = 1 if $value; } } plan skip_all => '2FA security policy is disabled on the server' if !$securitypolicy_enabled; plan skip_all => 'Security policies do not apply to API calls on the server' if !$securitypolicy_xml_api_enabled; my $pubapi = cPanel::PublicAPI->new( 'ssl_verify_mode' => 0 ); my $res = eval { $pubapi->whm_api('applist') }; if ($@) { plan skip_all => "Failed to verify API access as current user: $@"; } if ( exists $res->{'data'}->{'app'} && ref $res->{'data'}->{'app'} eq 'ARRAY' ) { return $pubapi if grep { $_ eq 'createacct' } @{ $res->{'data'}->{'app'} }; } plan skip_all => "Current user doesn't appear to have proper privileges"; } ��cpan-changes.t��0000644��00000000423�15125143403�0007255 0��ustar�00��#!/usr/bin/env perl use Test::More; plan skip_all => 'Release tests not required for installation' if not $ENV{RELEASE_TESTING}; eval { require Test::CPAN::Changes }; plan skip_all => 'Test::CPAN::Changes required for this test' if $@; Test::CPAN::Changes::changes_ok(); ��00-load.t��0000644��00000000266�15125143403�0006067 0��ustar�00��#!perl -T use Test::More tests => 1; BEGIN { use_ok('cPanel::PublicAPI') \|\| print "Bail out! "; } diag("Testing cPanel::PublicAPI $cPanel::PublicAPI::VERSION, Perl $], $^X"); ��lib/PubApiTest.pm��0000644��00000004772�15125143403�0007700 0��ustar�00��package PubApiTest; use cPanel::PublicAPI; @PubApiTest::ISA = qw( cPanel::PublicAPI ); use strict; use warnings; use Test::More; # This is used to specify what a specific call be using our $test_config = {}; # Used to test the actual input to api_request sub api_request { my ( $self, $service, $uri, $method, $formdata ) = @_; undef $self->{'error'}; if ( defined $test_config->{'badcall'} ) { my $badcall_return; if ( $test_config->{'badcall'} eq 'whmapi' ) { $badcall_return = '{"error":"Unknown App Requested: asdf"}'; } elsif ( $test_config->{'badcall'} eq 'cpanelapi2' ) { $badcall_return = '{"cpanelresult":{"apiversion":2,"error":"Could not find function \'test\' in module \'Test\'","func":"test","module":"Test"}}'; } elsif ( $test_config->{'badcall'} eq 'cpanelapi1' ) { $badcall_return = '{"apiversion":"1","type":"event","module":"Test","func":"test","source":"module","data":{"result":""},"event":{"reason":"Test::test() failed: Undefined subroutine &Cpanel::Test::Test_test called at (eval 21) line 1.\n","result":0}}'; } return 0, 'failed', \$badcall_return; } is( $service, $test_config->{'service'}, 'Service is correct for ' . $test_config->{'call'} ); is( $uri, $test_config->{'uri'}, 'URI is correct for ' . $test_config->{'call'} ); is( $method, $test_config->{'method'}, 'Method is correct for ' . $test_config->{'call'} ); if ( exists $test_config->{'test_formdata'} && $test_config->{'test_formdata'} eq 'hash' ) { is_deeply( $formdata, $test_config->{'formdata'}, 'Formdata is correct for ' . $test_config->{'call'} ); } elsif ( exists $test_config->{'test_formdata'} && $test_config->{'test_formdata'} eq 'string' ) { is( $formdata, $test_config->{'formdata'}, 'Fromdata is correct for ' . $test_config->{'call'} ); } my $return_format = 'string'; if ( $uri =~ /\/json-api\// ) { $return_format = 'json'; } elsif ( $uri =~ /\/xml-api\// ) { $return_format = 'xml'; } is( $return_format, $test_config->{'return_format'}, 'Serialization format correct for ' . $test_config->{'call'} ); my $return; if ( $return_format eq 'json' ) { $return = '{"something":"somethinglese"}'; } elsif ( $return_format eq 'xml' ) { $return = '<node><something>somethingelse</something></node>'; } else { $return = 'some data goes here'; } return '1', 'ok', \$return; } 1; ��03-api-query.t��0000644��00000015542�15125143403�0007072 0��ustar�00��#!/usr/bin/perl use strict; use warnings; use Test::More; # last test to print use cPanel::PublicAPI (); my @getpwuid = getpwuid($>); my $homedir = $getpwuid[7]; my $user = $getpwuid[0]; if ( !-d '/usr/local/cpanel' ) { plan skip_all => 'This test requires that cPanel and WHM are installed on a server'; } if ( !-e $homedir . '/.accesshash' ) { plan skip_all => 'This test requires that an account hash is defined (see "Setup Remote Access Keys" in WHM)'; } # SSL tests my $pubapi = check_api_access(); isa_ok( $pubapi, 'cPanel::PublicAPI' ); my $res = $pubapi->api_request( 'whostmgr', '/xml-api/loadavg', 'GET', {} ); like( $$res, qr/<loadavg>\s<one>\d+\.\d+<\/one>\s<five>\d+\.\d+<\/five>\s<fifteen>\d+\.\d+<\/fifteen>\s<\/loadavg>/, 'whm get no params' ); # Create the test regex for reuse my $createacct_regex = qr/<statusmsg>.is a reserved username.<\/statusmsg>/; $res = $pubapi->api_request( 'whostmgr', '/xml-api/createacct', 'GET', { 'username' => 'test', 'domain' => 'test.com' } ); like( $$res, $createacct_regex, 'ssl whm get hash params' ); $res = $pubapi->api_request( 'whostmgr', '/xml-api/createacct', 'GET', 'username=test&domain=test.com' ); like( $$res, $createacct_regex, 'ssl whm get string params' ); $res = $pubapi->api_request( 'whostmgr', '/xml-api/createacct', 'POST', { 'username' => 'test', 'domain' => 'test.com' } ); like( $$res, $createacct_regex, 'ssl whm post hash params' ); $res = $pubapi->api_request( 'whostmgr', '/xml-api/createacct', 'POST', 'username=test&domain=test.com' ); like( $$res, $createacct_regex, 'ssl whm post string params' ); # Create account for cpanel & reseller testing if ( !-e '/var/cpanel/users/papiunit' ) { my $password = generate_password(); $res = $pubapi->api_request( 'whostmgr', '/xml-api/createacct', 'POST', { 'username' => 'papiunit', 'password' => $password, 'domain' => 'cpanel-public-api-test.acct', } ); like( $$res, qr/Account Creation Ok/, 'Test account created' ); # skip is not used here due to the other code contained within this block. if ( $$res =~ /Account Creation Ok/ ) { my $cp_pubapi = cPanel::PublicAPI->new( 'user' => 'papiunit', 'pass' => $password, 'ssl_verify_mode' => 0, ); isa_ok( $cp_pubapi, 'cPanel::PublicAPI' ); is( $cp_pubapi->{'operating_mode'}, 'session', 'Session operating mode is set properly when user/pass is used' ); ok( !defined $cp_pubapi->{'cookie_jars'}->{'cpanel'}, 'no cookies have been established for the cpanel service before the first query is made' ); ok( !defined $cp_pubapi->{'security_tokens'}->{'cpanel'}, 'no security_token has been set for the cpanel service before the first query is made' ); $res = $cp_pubapi->api_request( 'cpanel', '/xml-api/cpanel', 'GET', 'cpanel_xmlapi_module=StatsBar&cpanel_xmlapi_func=stat&display=diskusage' ); like( $$res, qr/<module>StatsBar<\/module>/, 'ssl cpanel get string params' ); my $security_token = $cp_pubapi->{'security_tokens'}->{'cpanel'}; ok( $security_token, 'security token for cpanel has been set upon first request' ); $res = $cp_pubapi->api_request( 'cpanel', '/xml-api/cpanel', 'GET', { 'cpanel_xmlapi_module' => 'StatsBar', 'cpanel_xmlapi_func' => 'stat', 'display' => 'diskusage' } ); like( $$res, qr/<module>StatsBar<\/module>/, 'ssl cpanel post hash params' ); is( $cp_pubapi->{'security_tokens'}->{'cpanel'}, $security_token, 'security_token was not changed when the second cpanel request was made' ); $res = $cp_pubapi->api_request( 'cpanel', '/xml-api/cpanel', 'POST', 'cpanel_xmlapi_module=StatsBar&cpanel_xmlapi_func=stat&display=diskusage' ); like( $$res, qr/<module>StatsBar<\/module>/, 'ssl cpanel get string params' ); $res = $cp_pubapi->api_request( 'cpanel', '/xml-api/cpanel', 'POST', { 'cpanel_xmlapi_module' => 'StatsBar', 'cpanel_xmlapi_func' => 'stat', 'display' => 'diskusage' } ); like( $$res, qr/<module>StatsBar<\/module>/, 'ssl cpanel post hash params' ); $res = $pubapi->api_request( 'whostmgr', '/xml-api/removeacct', 'GET', { 'user' => 'papiunit' } ); like( $$res, qr/papiunit account removed/, 'Test Account Removed' ); } } my $cp_conf = load_cpanel_config(); my $nonssl_tests = 0; if ( !$cp_conf->{'requiressl'} && !$cp_conf->{'alwaysredirecttossl'} ) { $nonssl_tests = 1; } SKIP: { skip 'nonssl querying is not supported on this server', 5, unless $nonssl_tests; my $unsecure = cPanel::PublicAPI->new( 'usessl' => 0 ) if $nonssl_tests; isa_ok( $unsecure, 'cPanel::PublicAPI' ); $res = $unsecure->api_request( 'whostmgr', '/xml-api/loadavg', 'GET' ) if $nonssl_tests; like( $$res, qr/<loadavg>\s<one>\d+\.\d+<\/one>\s<five>\d+\.\d+<\/five>\s<fifteen>\d+\.\d+<\/fifteen>\s<\/loadavg>/, 'nossl whm get no params' ); $res = $unsecure->api_request( 'whostmgr', '/xml-api/createacct', 'GET', { 'username' => 'test', 'domain' => 'test.com' } ); like( $$res, $createacct_regex, 'nossl whm get hash params' ) if $nonssl_tests; $res = $unsecure->api_request( 'whostmgr', '/xml-api/createacct', 'GET', 'username=test&domain=test.com' ); like( $$res, $createacct_regex, 'nossl whm get string params' ) if $nonssl_tests; $res = $unsecure->api_request( 'whostmgr', '/xml-api/createacct', 'POST', { 'username' => 'test', 'domain' => 'test.com' } ); like( $$res, $createacct_regex, 'nossl whm post hash params' ) if $nonssl_tests; $res = $unsecure->api_request( 'whostmgr', '/xml-api/createacct', 'POST', 'username=test&domain=test.com' ); like( $$res, $createacct_regex, 'nossl whm post string params' ) if $nonssl_tests; } done_testing(); # used for generating the password of a test account sub generate_password { my @chars = ( 'A' .. 'Z', 'a' .. 'z', '0' .. '9' ); my $pass = ''; foreach ( 1 .. 32 ) { $pass .= $chars[ int rand @chars ]; } return $pass; } sub load_cpanel_config { my %cpanel_config; open( my $config_fh, '<', '/var/cpanel/cpanel.config' ) \|\| BAIL_OUT('Could not load /var/cpanel/cpanel.config'); foreach my $line ( readline($config_fh) ) { next if $line !~ /=/; chomp $line; my ( $key, $value ) = split( /=/, $line, 2 ); $cpanel_config{$key} = $value; } return \%cpanel_config; } sub check_api_access { my $pubapi = cPanel::PublicAPI->new( 'ssl_verify_mode' => 0 ); my $res = eval { $pubapi->whm_api('applist') }; if ($@) { plan skip_all => "Failed to verify API access as current user: $@"; } if ( exists $res->{'data'}->{'app'} && ref $res->{'data'}->{'app'} eq 'ARRAY' ) { return $pubapi if grep { $_ eq 'createacct' } @{ $res->{'data'}->{'app'} }; } plan skip_all => "Current user doesn't appear to have proper privileges"; } ��file_contains_utf8.t��0000644��00000005743�15125143407�0010527 0��ustar�00��use strict; use warnings; use utf8; use Test::Builder::Tester; use Test::More 1; use Test::File; # Hello world from utf8 test file: # http://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt my $string1 = 'Καλημέρα κόσμε'; my $string2 = 'コンニチハ'; require "./t/setup_common"; my $file = 'utf8_file'; open my $fh, '>', $file or print "bail out! Could not write to utf8_file: $!"; binmode($fh, ':encoding(UTF-8)'); $fh->print("$string1$/$/$/"); $fh->print("$string2$/"); $fh->close; my $contents = do { open $fh, '<', $file; binmode($fh, ':encoding(UTF-8)'); local $/; <$fh>; }; $fh->close; my $pattern1 = qr/(?m:^$string1$)/; my $pattern2 = qr/(?m:^$string2$)/; my $bad_pattern = 'x' x 20; $bad_pattern = qr/(?m:^$bad_pattern$)/; # like : single pattern test_out( "ok 1 - utf8_file contains $pattern1" ); file_contains_utf8_like( $file, $pattern1 ); test_test(); test_out( "not ok 1 - utf8_file contains $bad_pattern" ); test_fail(+2); like_diag($contents, $bad_pattern, "doesn't match"); file_contains_utf8_like( 'utf8_file', $bad_pattern ); test_test(); # unlike : single pattern test_out( "ok 1 - utf8_file doesn't contain $bad_pattern" ); file_contains_utf8_unlike( $file, $bad_pattern ); test_test(); test_out( "not ok 1 - utf8_file doesn't contain $pattern1" ); test_fail(+2); like_diag($contents, $pattern1, "matches"); file_contains_utf8_unlike( 'utf8_file', $pattern1 ); test_test(); # like : multiple patterns test_out( "ok 1 - utf8_file contains $pattern1" ); test_out( "ok 2 - utf8_file contains $pattern2" ); file_contains_utf8_like( $file, [ $pattern1, $pattern2 ] ); test_test(); test_out( "ok 1 - file has the goods" ); test_out( "ok 2 - file has the goods" ); file_contains_utf8_like( $file, [ $pattern1, $pattern2 ], 'file has the goods' ); test_test(); test_out( "ok 1 - utf8_file contains $pattern1" ); test_out( "not ok 2 - utf8_file contains $bad_pattern" ); test_fail(+2); like_diag($contents, $bad_pattern, "doesn't match"); file_contains_utf8_like( 'utf8_file', [ $pattern1, $bad_pattern ] ); test_test(); # unlike : multiple patterns test_out( "ok 1 - utf8_file doesn't contain $bad_pattern" ); test_out( "ok 2 - utf8_file doesn't contain $bad_pattern" ); file_contains_utf8_unlike( $file, [ $bad_pattern, $bad_pattern ] ); test_test(); test_out( "ok 1 - file has the goods" ); test_out( "ok 2 - file has the goods" ); file_contains_utf8_unlike( $file, [ $bad_pattern, $bad_pattern ], 'file has the goods' ); test_test(); test_out( "ok 1 - utf8_file doesn't contain $bad_pattern" ); test_out( "not ok 2 - utf8_file doesn't contain $pattern1" ); test_fail(+2); like_diag($contents, $pattern1, "matches"); file_contains_utf8_unlike( 'utf8_file', [ $bad_pattern, $pattern1 ] ); test_test(); done_testing(); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # sub like_diag { my ($string, $pattern, $verb) = @_; my $diag = ' ' x 18 . "'$string'\n"; $diag .= sprintf("%17s '%s'", $verb, $pattern); $diag =~ s/^/# /mg; test_err($diag); } ��file_sizes.t��0000644��00000011326�15125143407�0007072 0��ustar�00��use strict; use Test::Builder::Tester; use Test::More 1; use Test::File; require "./t/setup_common"; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # test_out( 'ok 1 - zero_file is empty' ); file_empty_ok( 'zero_file' ); test_out( 'ok 2 - zero_file really is empty' ); file_empty_ok( 'zero_file', 'zero_file really is empty' ); test_test(); test_out( 'ok 1 - min_file is not empty' ); file_not_empty_ok( 'min_file' ); test_out( 'ok 2 - min_file really is not empty' ); file_not_empty_ok( 'min_file', 'min_file really is not empty' ); test_test(); subtest works => sub { my $file = 'min_file'; file_exists_ok( $file ); my $actual_size = -s $file; my $under_size = $actual_size - 3; my $over_size = $actual_size + 3; cmp_ok( $actual_size, '>', 10, "$file should be at least 10 bytes" ); test_out( "ok 1 - $file has right size" ); file_size_ok( $file, $actual_size ); test_out( "ok 2 - $file really has right size" ); file_size_ok( $file, $actual_size, "$file really has right size" ); test_test(); test_out( "ok 1 - $file is under $over_size bytes" ); file_max_size_ok( $file, $over_size ); test_out( "ok 2 - $file really is under $over_size bytes" ); file_max_size_ok( $file, $over_size, "$file really is under $over_size bytes" ); test_test(); test_out( "ok 1 - $file is over $under_size bytes" ); file_min_size_ok( $file, $under_size ); test_out( "ok 2 - $file really is over $under_size bytes" ); file_min_size_ok( $file, $under_size, "$file really is over $under_size bytes" ); test_test(); done_testing(); }; subtest wrong_size => sub { my $file = 'min_file'; file_exists_ok( $file ); my $actual_size = -s $file; my $under_size = $actual_size - 3; my $over_size = $actual_size + 3; cmp_ok( $actual_size, '>', 10, "$file should be at least 10 bytes" ); test_out( "not ok 1 - $file has right size" ); test_diag( "file [$file] has actual size [$actual_size] not [$under_size]\n" . " # Failed test '$file has right size'\n" . " # at $0 line " . line_num(+5) . "." ); file_size_ok( $file, $under_size ); test_test(); test_out( "not ok 1 - $file is under $under_size bytes" ); test_diag( "file [$file] has actual size [$actual_size] greater than [$under_size]\n" . " # Failed test '$file is under $under_size bytes'\n" . " # at $0 line " . line_num(+5) . "." ); file_max_size_ok( $file, $under_size ); test_test(); test_out( "not ok 1 - $file is over $over_size bytes" ); test_diag( "file [$file] has actual size [$actual_size] less than [$over_size]\n" . " # Failed test '$file is over $over_size bytes'\n" . " # at $0 line " . line_num(+5) . "." ); file_min_size_ok( $file, $over_size ); test_test(); test_out( "not ok 1 - $file is empty" ); test_diag( "file [$file] exists with non-zero size\n" . " # Failed test '$file is empty'\n" . " # at $0 line " . line_num(+5) . "." ); file_empty_ok( $file ); test_test(); test_out( "not ok 1 - zero_file is not empty" ); test_diag( "file [zero_file] exists with zero size\n" . " # Failed test 'zero_file is not empty'\n" . " # at $0 line " . line_num(+5) . "." ); file_not_empty_ok( 'zero_file' ); test_test(); done_testing(); }; subtest doesnt_work_with_missing_file => sub { my $not_there = 'not_there'; ok( ! -e $not_there, "file [$not_there] doesn't exist (good)" ); test_out( "not ok 1 - $not_there has right size" ); test_diag( "file [$not_there] does not exist\n" . " # Failed test '$not_there has right size'\n" . " # at $0 line " . line_num(+5) . "." ); file_size_ok( $not_there, 53 ); test_test(); test_out( "not ok 1 - $not_there is under 54 bytes" ); test_diag( "file [$not_there] does not exist\n" . " # Failed test '$not_there is under 54 bytes'\n" . " # at $0 line " . line_num(+5) . "." ); file_max_size_ok( $not_there, 54 ); test_test(); test_out( "not ok 1 - $not_there is over 50 bytes" ); test_diag( "file [$not_there] does not exist\n" . " # Failed test '$not_there is over 50 bytes'\n" . " # at $0 line " . line_num(+5) . "." ); file_min_size_ok( $not_there, 50 ); test_test(); test_out( "not ok 1 - $not_there is empty" ); test_diag( "file [$not_there] does not exist\n" . " # Failed test '$not_there is empty'\n" . " # at $0 line " . line_num(+5) . "." ); file_empty_ok( $not_there ); test_test(); test_out( "not ok 1 - $not_there is not empty" ); test_diag( "file [$not_there] does not exist\n" . " # Failed test '$not_there is not empty'\n" . " # at $0 line " . line_num(+5) . "." ); file_not_empty_ok( $not_there ); test_test(); done_testing(); }; done_testing(); ��win32.t��0000644��00000001641�15125143407�0005677 0��ustar�00��use strict; use warnings; use Test::Builder::Tester; use Test::More 1; subtest load => sub { use_ok( 'Test::File' ); ok( defined &{ "Test::File::_win32" }, "_win32 defined" ); }; subtest darwin => sub { local $^O = 'darwin'; ok( ! Test::File::_win32(), "Returns false for darwin" ); }; subtest win32 => sub { local $^O = 'Win32'; ok( Test::File::_win32(), "Returns true for Win32" ); }; subtest linux_pretend_win32 => sub { local %ENV; $ENV{PRETEND_TO_BE_WIN32} = 1; local $^O = 'linux'; ok( Test::File::_win32(), "Returns true for linux when ENV{PRETEND_TO_BE_WIN32} is defined" ); }; subtest file_modes => sub { local $^O = 'Win32'; my @subs = qw( file_mode_is file_mode_isnt file_executable_ok file_not_executable_ok ); foreach my $sub ( @subs ) { no strict 'refs'; test_out("ok 1 # skip $sub doesn't work on Windows"); &{$sub}(); test_test(); } done_testing(); }; done_testing(); ��test_files.t��0000644��00000023765�15125143407�0007111 0��ustar�00��use strict; use Test::Builder::Tester; use Test::More 1; use Test::File; =pod max_file non_zero_file not_readable readable zero_file executable min_file not_executable not_writable writable =cut require "./t/setup_common"; diag "Warnings about file_writeable_ok are fine. It's a deprecated name that still works."; subtest readable => sub { my $label = 'file <readable> exists'; test_out( 'ok 1 - readable exists' ); file_exists_ok( 'readable' ); test_out( "ok 2 - $label" ); file_exists_ok( 'readable', $label ); test_test(); done_testing(); }; subtest exists_fails => sub { test_out( 'not ok 1 - fooey exists' ); test_diag( 'file [fooey] does not exist'); test_diag( " Failed test 'fooey exists'"); test_diag( " at " . __FILE__ . " line " . (__LINE__+1) . "."); file_exists_ok( 'fooey' ); test_test(); done_testing(); }; subtest not_exists => sub { my $label = 'file <readable> exists'; test_out( 'ok 1 - fooey does not exist' ); file_not_exists_ok( 'fooey' ); test_out( "ok 2 - $label" ); file_not_exists_ok( 'fooey', $label ); test_test(); done_testing(); }; subtest not_exists_fails => sub { test_out( 'not ok 1 - readable does not exist' ); test_diag( 'file [readable] exists'); test_diag( " Failed test 'readable does not exist'"); test_diag( " at " . __FILE__ . " line " . (__LINE__+1) . "."); file_not_exists_ok( 'readable' ); test_test(); done_testing(); }; subtest readable => sub { test_out( 'ok 1 - readable is readable' ); file_readable_ok( 'readable' ); test_out( 'ok 2 - readable really is readable' ); file_readable_ok( 'readable', 'readable really is readable' ); test_test(); done_testing(); }; subtest readable_fails => sub { SKIP: { skip "Superuser has special privileges", 2, is_unix_superuser(); test_out( 'not ok 1 - non_readable is readable' ); test_diag("file [non_readable] is not readable"); test_diag(" Failed test 'non_readable is readable'"); test_diag( " at " . __FILE__ . " line " . (__LINE__+1) . "."); file_readable_ok( 'non_readable' ); test_test(); done_testing(); }}; subtest not_readable_fails => sub { SKIP: { skip "Superuser has special privileges", 3, if is_unix_superuser(); skip "Not possible to make file unreadable on MSYS" if is_msys(); test_out( 'ok 1 - writeable is not readable' ); file_not_readable_ok( 'writeable' ); test_out( 'ok 2 - writeable really is not readable' ); file_not_readable_ok( 'writeable', 'writeable really is not readable' ); test_out( 'not ok 3 - readable is not readable' ); test_diag('file [readable] is readable'); test_diag(" Failed test 'readable is not readable'"); test_diag( " at " . __FILE__ . " line " . (__LINE__+1) . "."); file_not_readable_ok( 'readable' ); test_test(); done_testing(); }}; subtest writable_fails => sub { my $label = 'writable has custom label'; test_out( 'ok 1 - writable is writable' ); file_writable_ok( 'writable' ); test_out( "ok 2 - $label" ); file_writable_ok( 'writable', $label ); if( is_msys() or is_unix_superuser() ) { test_out( 'ok 3 - readable is writable' ); } else { test_out( 'not ok 3 - readable is writable' ); test_diag('file [readable] is not writable'); test_diag(" Failed test 'readable is writable'"); test_diag( " at " . __FILE__ . " line " . (__LINE__+2) . "."); } file_writable_ok( 'readable' ); test_test(); done_testing(); }; subtest not_writable => sub { SKIP: { skip "Superuser has special privileges", 1, if is_unix_superuser(); skip "Not possible to make file unreadable on MSYS" if is_msys(); test_out( 'ok 1 - readable is not writable' ); test_out( 'not ok 2 - writable is not writable' ); test_diag('file [writable] is writable'); test_diag(" Failed test 'writable is not writable'"); test_diag( " at " . __FILE__ . " line " . (__LINE__+2) . "."); file_not_writable_ok( 'readable' ); file_not_writable_ok( 'writable' ); test_test(); done_testing(); }}; subtest executable => sub { if (Test::File::_win32()) { test_out("ok 1 # skip file_executable_ok doesn't work on Windows"); test_out("ok 2 # skip file_executable_ok doesn't work on Windows"); test_out("ok 3 # skip file_executable_ok doesn't work on Windows"); } else { test_out("ok 1 - executable is executable"); test_out("ok 2 - executable really is executable"); test_out("not ok 3 - not_executable is executable"); test_diag("file [not_executable] is not executable"); test_diag(" Failed test 'not_executable is executable'"); test_diag(" at " . __FILE__ . " line " . (__LINE__+4) . "."); } file_executable_ok( 'executable' ); file_executable_ok( 'executable', 'executable really is executable' ); file_executable_ok( 'not_executable' ); test_test(); done_testing(); }; subtest not_executable => sub { if (Test::File::_win32()) { test_out("ok 1 # skip file_not_executable_ok doesn't work on Windows"); test_out("ok 2 # skip file_not_executable_ok doesn't work on Windows"); test_out("ok 3 # skip file_not_executable_ok doesn't work on Windows"); } else { test_out("ok 1 - not_executable is not executable"); test_out("ok 2 - not_executable really is not executable"); test_out("not ok 3 - executable is not executable"); test_diag("file [executable] is executable"); test_diag(" Failed test 'executable is not executable'"); test_diag(" at " . __FILE__ . " line " . (__LINE__+4) . "."); } file_not_executable_ok( 'not_executable' ); file_not_executable_ok( 'not_executable', 'not_executable really is not executable' ); file_not_executable_ok( 'executable' ); test_test(); done_testing(); }; subtest mode_is => sub { if (Test::File::_win32()) { test_out("ok 1 # skip file_mode_is doesn't work on Windows"); test_out("ok 2 # skip file_mode_is doesn't work on Windows"); test_out("ok 3 # skip file_mode_is doesn't work on Windows"); } else { test_out("ok 1 - executable mode is 0100"); test_out("ok 2 - executable mode really is 0100"); test_out("not ok 3 - executable mode is 0200"); test_diag("file [executable] mode is not 0200"); test_diag(" Failed test 'executable mode is 0200'"); test_diag(" at " . __FILE__ . " line " . (__LINE__+4) . "."); } file_mode_is( 'executable', 0100 ); file_mode_is( 'executable', 0100, 'executable mode really is 0100' ); file_mode_is( 'executable', 0200 ); test_test(); done_testing(); }; subtest mode_has => sub { if (Test::File::_win32()) { test_out("ok 1 # skip file_mode_has doesn't work on Windows"); test_out("ok 2 # skip file_mode_has doesn't work on Windows"); test_out("ok 3 # skip file_mode_has doesn't work on Windows"); test_out("ok 4 # skip file_mode_has doesn't work on Windows" ); } else { test_out("ok 1 - executable mode has all bits of 0100"); test_out("ok 2 - executable mode really has all bits of 0100"); test_out("not ok 3 - executable mode has all bits of 0200"); test_diag("file [executable] mode is missing component 0200"); test_diag(" Failed test 'executable mode has all bits of 0200'"); test_diag(" at " . __FILE__ . " line " . (__LINE__+8) . "."); test_out( "not ok 4 - executable mode has all bits of 0111" ); test_diag("file [executable] mode is missing component 0011"); test_diag(" Failed test 'executable mode has all bits of 0111'"); test_diag(" at " . __FILE__ . " line " . (__LINE__+5) . "."); } file_mode_has( 'executable', 0100 ); file_mode_has( 'executable', 0100, 'executable mode really has all bits of 0100'); file_mode_has( 'executable', 0200 ); file_mode_has( 'executable', 0111 ); test_test(); done_testing(); }; subtest mode_isnt => sub { if (Test::File::_win32) { test_out( "ok 1 # skip file_mode_isnt doesn't work on Windows" ); test_out( "ok 2 # skip file_mode_isnt doesn't work on Windows" ); test_out( "ok 3 # skip file_mode_isnt doesn't work on Windows" ); } else { test_out( "ok 1 - executable mode is not 0200" ); test_out( "ok 2 - executable mode really is not 0200" ); test_out( "not ok 3 - executable mode is not 0100" ); test_diag("file [executable] mode is 0100"); test_diag(" Failed test 'executable mode is not 0100'"); test_diag(" at " . __FILE__ . " line " . (__LINE__+4) . "."); } file_mode_isnt( 'executable', 0200 ); file_mode_isnt( 'executable', 0200, 'executable mode really is not 0200' ); file_mode_isnt( 'executable', 0100 ); test_test(); done_testing(); }; subtest mode_hasnt => sub { if (Test::File::_win32()) { test_out( "ok 1 # skip file_mode_hasnt doesn't work on Windows" ); test_out( "ok 2 # skip file_mode_hasnt doesn't work on Windows" ); test_out( "ok 3 # skip file_mode_hasnt doesn't work on Windows" ); } else { test_out( "ok 1 - executable mode has no bits of 0200" ); test_out( "ok 2 - executable mode really has no bits of 0200" ); test_out( "not ok 3 - executable mode has no bits of 0111" ); test_diag("file [executable] mode has forbidden component 0100"); test_diag(" Failed test 'executable mode has no bits of 0111'"); test_diag(" at " . __FILE__ . " line " . (__LINE__+5) . "."); } file_mode_hasnt( 'executable', 0200 ); file_mode_hasnt( 'executable', 0200, 'executable mode really has no bits of 0200' ); file_mode_hasnt( 'executable', 0111 ); test_test(); done_testing(); }; subtest mode => sub { my $s = Test::File::_win32() ? "# skip file_mode_is doesn't work on Windows" : "- readable mode is 0400"; test_out( "ok 1 $s" ); file_mode_is( 'readable', 0400 ); test_test(); done_testing(); }; subtest mode_isnt => sub { my $s = Test::File::_win32() ? "# skip file_mode_isnt doesn't work on Windows" : "- readable mode is not 0200"; test_out( "ok 1 $s" ); file_mode_isnt( 'readable', 0200 ); test_test(); done_testing(); }; subtest mode_writable => sub { my $s = Test::File::_win32() ? "# skip file_mode_is doesn't work on Windows" : "- writable mode is 0200"; test_out( "ok 1 $s" ); file_mode_is( 'writable', 0200 ); test_test(); done_testing(); }; subtest mode => sub { my $s = Test::File::_win32() ? "# skip file_mode_isnt doesn't work on Windows" : "- writable mode is not 0100"; test_out( "ok 1 $s" ); file_mode_isnt( 'writable', 0100 ); test_test(); done_testing(); }; done_testing(); ��file_contains.t��0000644��00000012062�15125143407�0007551 0��ustar�00��use strict; use warnings; use Test::Builder::Tester; use Test::More 1; use Test::File; require "./t/setup_common"; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # my $file = 'min_file'; my $contents = do { open FH, $file; local $/; <FH> }; close FH; my $pattern1 = 'x' x 11; $pattern1 = qr/(?mx:^ $pattern1 $)/; my $pattern2 = 'x' x 40; $pattern2 = qr/(?mx:^ $pattern2 $)/; my $bad_pattern = 'x' x 20; $bad_pattern = qr/(?mx:^ $bad_pattern $)/; # like : single pattern test_out( "ok 1 - min_file contains $pattern1" ); file_contains_like( $file, $pattern1 ); test_test(); test_out( "not ok 1 - bmoogle contains $pattern1" ); test_diag( 'file [bmoogle] does not exist' ); test_fail(+1); file_contains_like( 'bmoogle', $pattern1 ); test_test(); SKIP: { skip "Superuser has special privileges", 1 if is_unix_superuser(); skip "Windows has a different idea of readable", 1 if is_win32(); skip "Not possible to make file unreadable on MSYS", 1 if is_msys(); test_out( "not ok 1 - not_readable contains $pattern1" ); test_diag( 'file [not_readable] is not readable' ); test_fail(+1); file_contains_like( 'not_readable', $pattern1 ); test_test(); } test_out( "not ok 1 - min_file contains $bad_pattern" ); test_fail(+2); like_diag($contents, $bad_pattern, "doesn't match"); file_contains_like( 'min_file', $bad_pattern ); test_test(); # unlike : single pattern test_out( "ok 1 - min_file doesn't contain $bad_pattern" ); file_contains_unlike( $file, $bad_pattern ); test_test(); test_out( "not ok 1 - bmoogle doesn't contain $bad_pattern" ); test_diag( 'file [bmoogle] does not exist' ); test_fail(+1); file_contains_unlike( 'bmoogle', $bad_pattern ); test_test(); SKIP: { skip "Superuser has special privileges", 1 if is_unix_superuser(); skip "Windows has a different idea of readable", 1 if is_win32(); skip "Not possible to make file unreadable on MSYS", 1 if is_msys(); test_out( "not ok 1 - not_readable doesn't contain $bad_pattern" ); test_diag( 'file [not_readable] is not readable' ); test_fail(+1); file_contains_unlike( 'not_readable', $bad_pattern ); test_test(); } test_out( "not ok 1 - min_file doesn't contain $pattern1" ); test_fail(+2); like_diag($contents, $pattern1, "matches"); file_contains_unlike( 'min_file', $pattern1 ); test_test(); # like : multiple patterns test_out( "ok 1 - min_file contains $pattern1" ); test_out( "ok 2 - min_file contains $pattern2" ); file_contains_like( $file, [ $pattern1, $pattern2 ] ); test_test(); test_out( "ok 1 - file has the goods" ); test_out( "ok 2 - file has the goods" ); file_contains_like( $file, [ $pattern1, $pattern2 ], 'file has the goods' ); test_test(); test_out( "not ok 1 - bmoogle contains $pattern1" ); test_diag( 'file [bmoogle] does not exist' ); test_fail(+1); file_contains_like( 'bmoogle', [ $pattern1, $pattern2 ] ); test_test(); SKIP: { skip "Superuser has special privileges", 1 if is_unix_superuser(); skip "Windows has a different idea of readable", 1 if is_win32(); skip "Not possible to make file unreadable on MSYS", 1 if is_msys(); test_out( "not ok 1 - not_readable contains $pattern1" ); test_diag( 'file [not_readable] is not readable' ); test_fail(+1); file_contains_like( 'not_readable', [ $pattern1, $pattern2 ] ); test_test(); } test_out( "ok 1 - min_file contains $pattern1" ); test_out( "not ok 2 - min_file contains $bad_pattern" ); test_fail(+2); like_diag($contents, $bad_pattern, "doesn't match"); file_contains_like( 'min_file', [ $pattern1, $bad_pattern ] ); test_test(); # unlike : multiple patterns test_out( "ok 1 - min_file doesn't contain $bad_pattern" ); test_out( "ok 2 - min_file doesn't contain $bad_pattern" ); file_contains_unlike( $file, [ $bad_pattern, $bad_pattern ] ); test_test(); test_out( "ok 1 - file has the goods" ); test_out( "ok 2 - file has the goods" ); file_contains_unlike( $file, [ $bad_pattern, $bad_pattern ], 'file has the goods' ); test_test(); test_out( "not ok 1 - bmoogle doesn't contain $bad_pattern" ); test_diag( 'file [bmoogle] does not exist' ); test_fail(+1); file_contains_unlike( 'bmoogle', [ $bad_pattern, $bad_pattern ] ); test_test(); SKIP: { skip "Superuser has special privileges", 1 if is_unix_superuser(); skip "Windows has a different idea of readable", 1 if is_win32(); skip "Not possible to make file unreadable on MSYS", 1 if is_msys(); test_out( "not ok 1 - not_readable doesn't contain $bad_pattern" ); test_diag( 'file [not_readable] is not readable' ); test_fail(+1); file_contains_unlike( 'not_readable', [ $bad_pattern, $bad_pattern ] ); test_test(); } test_out( "ok 1 - min_file doesn't contain $bad_pattern" ); test_out( "not ok 2 - min_file doesn't contain $pattern1" ); test_fail(+2); like_diag($contents, $pattern1, "matches"); file_contains_unlike( 'min_file', [ $bad_pattern, $pattern1 ] ); test_test(); done_testing(); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # sub like_diag { my ($string, $pattern, $verb) = @_; my $diag = ' ' x 18 . "'$string'\n"; $diag .= sprintf("%17s '%s'", $verb, $pattern); $diag =~ s/^/# /mg; test_err($diag); } ��owner.t��0000644��00000013374�15125143407�0006075 0��ustar�00��use strict; use Test::Builder::Tester; use Test::More; use Test::File; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #let's test with the first file we find in the current dir my( $filename, $file_gid, $owner_uid, $owner_name, $file_group_name ); eval { $filename = glob( "" ); die "Could not find a file" unless defined $filename; $owner_uid = ( stat $filename )[4]; die "failed to find ${filename}'s owner\n" unless defined $owner_uid; $file_gid = ( stat $filename )[5]; die "failed to find ${filename}'s owner\n" unless defined $file_gid; $owner_name = ( getpwuid $owner_uid )[0]; die "failed to find ${filename}'s owner as name\n" unless defined $owner_name; $file_group_name = ( getgrgid $file_gid )[0]; die "failed to find ${filename}'s group as name\n" unless defined $file_group_name; }; plan skip_all => "I can't find a file to test with: $@" if $@; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # find some name that isn't the one we found before my( $other_name, $other_uid, $other_group_name, $other_gid ); eval { for( my $i = 0; $i < 65535; $i++ ) { next if $i == $owner_uid; my @stats = getpwuid $i; next unless @stats; ( $other_uid, $other_name ) = ( $i, $stats[0] ); last; } # XXX: why the for loop? for( my $i = 0; $i < 65535; $i++ ) { next if $i == $file_gid; my @stats = getgrgid $i; next unless @stats; ( $other_gid, $other_group_name ) = ( $i, $stats[0] ); last; } die "Failed to find another uid" unless defined $other_uid; die "Failed to find name for other uid ($other_uid)" unless defined $other_name; die "Failed to find another gid" unless defined $other_gid; die "Failed to find name for other gid ($other_gid)" unless defined $other_group_name; }; plan skip_all => "I can't find a second user id to test with: $@" if $@; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # find some names that don't exist, to test bad input my( $invalid_user_name, $invalid_group_name ); eval { foreach my $user ( 'aaaa' .. 'zzzz' ) { my @stats = getpwnam $user; next if @stats; $invalid_user_name = $user; #diag "Using invalid user [$user] for tests"; last; } foreach my $group ( 'aaaa' .. 'zzzz' ) { my @stats = getpwnam $group; next if @stats; $invalid_group_name = $group; #diag "Using invalid group [$group] for tests"; last; } diag "Failed to find an invalid username" unless defined $other_uid; diag "Failed to find another gid" unless defined $other_gid; }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # test owner stuff owner_is( $filename, $owner_name, 'owner_is with text username' ); owner_is( $filename, $owner_uid, 'owner_is with numeric UID' ); owner_isnt( $filename, $other_name, 'owner_isnt with text username' ); owner_isnt( $filename, $other_uid, 'owner_isnt with numeric UID' ); my $name = 'Intentional owner_is failure with wrong user'; my $testname = "$filename belongs to $other_name"; test_out( "not ok 1 - $testname"); test_diag( "file [$filename] belongs to $owner_name ($owner_uid), not $other_name " . "($other_uid)\n" . "# Failed test '$testname'\n". "# at t/owner.t line " . line_num(+6) . "." ); owner_is( $filename, $other_name ); test_test( $name ); $name = "Intentional owner_is failure with invalid user [$invalid_user_name]"; $testname = "$filename belongs to $invalid_user_name"; test_out( "not ok 1 - $testname"); test_diag( "user [$invalid_user_name] does not exist on this system\n" . "# Failed test '$testname'\n". "# at t/owner.t line " . line_num(+5) . "." ); owner_is( $filename, $invalid_user_name ); test_test( $name ); $name = 'owner_isnt for non-existent name'; $testname = "$filename doesn't belong to $invalid_user_name"; test_out( "ok 1 - $testname"); owner_isnt( $filename, $invalid_user_name ); test_test( $name ); $name = 'Intentional owner_isnt failure'; $testname = "$filename doesn't belong to $owner_name"; test_out( "not ok 1 - $testname"); test_diag( "file [$filename] belongs to $owner_name ($owner_uid)\n" . "# Failed test '$testname'\n" . "# at t/owner.t line " . line_num(+5) . "." ); owner_isnt( $filename, $owner_name ); test_test( $name ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # test group stuff group_is( $filename, $file_group_name, 'group_is with text groupname' ); group_is( $filename, $file_group_name ); group_is( $filename, $file_gid, 'group_is with numeric GID' ); group_isnt( $filename, $other_group_name, 'group_isnt with text groupname' ); group_isnt( $filename, $other_gid, 'group_isnt with numeric GID' ); group_isnt( $filename, $other_gid ); $name = 'Intentional group_is failure'; test_out( "not ok 1 - $name"); test_diag( "file [$filename] belongs to $file_group_name ($file_gid), not ". "$other_group_name " . "($other_gid)\n" . "# Failed test '$name'\n". "# at t/owner.t line " . line_num(+7) . "." ); group_is( $filename, $other_group_name, $name ); test_test( $name ); $name = "Intentional group_is failure with invalid group [$invalid_group_name]"; test_out( "not ok 1 - $name"); test_diag( "group [$invalid_group_name] does not exist on this system\n" . "# Failed test '$name'\n". "# at t/owner.t line " . line_num(+5) . "." ); group_is( $filename, $invalid_group_name, $name ); test_test( $name ); $name = 'Intentional group_isnt failure'; test_out( "not ok 1 - $name"); test_diag( "file [$filename] belongs to $file_group_name ($file_gid)\n" . "# Failed test '$name'\n" . "# at t/owner.t line " . line_num(+5) . "." ); group_isnt( $filename, $file_group_name, $name ); test_test( $name ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # done_testing(); ��file_contains_encoded.t��0000644��00000005727�15125143407�0011244 0��ustar�00��use strict; use warnings; use utf8; use Test::Builder::Tester; use Test::More 1; use Test::File; # Hello world! I am a string. Russian, courtesy of Google Translate my $string1 = 'Привет мир!'; my $string2 = 'Я строкой'; my $encoding = 'KOI8-R'; require "./t/setup_common"; my $file = '$file'; open my $fh, '>', $file or print "bail out! Could not write to $file: $!"; binmode($fh, ":encoding($encoding)"); $fh->print("$string1$/$/$/"); $fh->print("$string2$/"); $fh->close; my $contents = do { open $fh, '<', $file; binmode($fh, ":encoding($encoding)"); local $/; <$fh>; }; $fh->close; my $pattern1 = qr/$string1/; my $pattern2 = qr/$string2/; my $bad_pattern = 'x' x 20; $bad_pattern = qr/(?m:^$bad_pattern$)/; # like : single pattern test_out( "ok 1 - $file contains $pattern1" ); file_contains_encoded_like( $file, $encoding, $pattern1 ); test_test(); test_out( "not ok 1 - $file contains $bad_pattern" ); test_fail(+2); like_diag($contents, $bad_pattern, "doesn't match"); file_contains_encoded_like( '$file', $encoding, $bad_pattern ); test_test(); # unlike : single pattern test_out( "ok 1 - $file doesn't contain $bad_pattern" ); file_contains_encoded_unlike( $file, $encoding, $bad_pattern ); test_test(); test_out( "not ok 1 - $file doesn't contain $pattern1" ); test_fail(+2); like_diag($contents, $pattern1, "matches"); file_contains_encoded_unlike( '$file', $encoding, $pattern1 ); test_test(); # like : multiple patterns test_out( "ok 1 - $file contains $pattern1" ); test_out( "ok 2 - $file contains $pattern2" ); file_contains_encoded_like( $file, $encoding, [ $pattern1, $pattern2 ] ); test_test(); test_out( "ok 1 - file has the goods" ); test_out( "ok 2 - file has the goods" ); file_contains_encoded_like( $file, $encoding, [ $pattern1, $pattern2 ], 'file has the goods' ); test_test(); test_out( "ok 1 - $file contains $pattern1" ); test_out( "not ok 2 - $file contains $bad_pattern" ); test_fail(+2); like_diag($contents, $bad_pattern, "doesn't match"); file_contains_encoded_like( '$file', $encoding, [ $pattern1, $bad_pattern ] ); test_test(); # unlike : multiple patterns test_out( "ok 1 - $file doesn't contain $bad_pattern" ); test_out( "ok 2 - $file doesn't contain $bad_pattern" ); file_contains_encoded_unlike( $file, $encoding, [ $bad_pattern, $bad_pattern ] ); test_test(); test_out( "ok 1 - file has the goods" ); test_out( "ok 2 - file has the goods" ); file_contains_encoded_unlike( $file, $encoding, [ $bad_pattern, $bad_pattern ], 'file has the goods' ); test_test(); test_out( "ok 1 - $file doesn't contain $bad_pattern" ); test_out( "not ok 2 - $file doesn't contain $pattern1" ); test_fail(+2); like_diag($contents, $pattern1, "matches"); file_contains_encoded_unlike( '$file', $encoding, [ $bad_pattern, $pattern1 ] ); test_test(); done_testing(); sub like_diag { my ($string, $pattern, $verb) = @_; my $diag = ' ' x 18 . "'$string'\n"; $diag .= sprintf("%17s '%s'", $verb, $pattern); $diag =~ s/^/# /mg; test_err($diag); } ��rt/30346.t��0000644��00000002313�15125143407�0006036 0��ustar�00��use strict; use Test::Builder::Tester; use Test::More 1; use_ok( 'Test::File' ); use Cwd; require './t/setup_common'; subtest file_does_not_exist => sub { my $file = "no_such_file-" . "$$" . time() . "b$<$>m"; unlink $file; my $name = "$file is not empty"; test_out( "not ok 1 - $name"); test_diag( "file [$file] does not exist\n" . " # Failed test '$name'\n". " # at $0 line " . line_num(+5) . "." ); file_not_empty_ok( $file ); test_test( $name ); done_testing(); }; subtest file_exists_non_zero => sub { my $file = 'min_file'; diag( "File is $file with size " . (-s $file) . " bytes" ); my $name = "$file is not empty"; test_out( "ok 1 - $name"); file_not_empty_ok( $file ); test_test( $name ); done_testing(); }; subtest file_exists_zero_size => sub { require File::Spec; my $file = 'file_not_empty_ok_test'; open my $fh, ">", $file; truncate $fh, 0; close $fh; my $name = "$file is not empty"; test_out( "not ok 1 - $name"); test_diag( "file [$file] exists with zero size\n" . " # Failed test '$name'\n". " # at $0 line " . line_num(+5) . "." ); file_not_empty_ok( $file ); test_test( $name ); unlink $file; done_testing(); }; done_testing(); ��load.t��0000644��00000000236�15125143407�0005653 0��ustar�00��use Test::More 1; my @classes = qw(Test::File); foreach my $class ( @classes ) { use_ok( $class ) or BAILOUT( "$class did not load" ); } done_testing(); ��test_dirs.t��0000644��00000002663�15125143407�0006742 0��ustar�00��use strict; use warnings; use Test::Builder::Tester; use Test::More 1; use Test::File; use File::Spec::Functions qw(catfile); require "./t/setup_common"; open FH, '>', catfile( qw(sub_dir subdir_file) ); close FH; test_out( 'ok 1 - sub_dir is a directory' ); test_out( 'ok 2 - sub_dir really is a directory' ); dir_exists_ok( 'sub_dir' ); dir_exists_ok( 'sub_dir', 'sub_dir really is a directory' ); test_test(); test_out( 'not ok 1 - bmoogle is a directory' ); test_diag( 'directory [bmoogle] does not exist' ); test_fail(+1); dir_exists_ok( 'bmoogle' ); test_test(); test_out( 'not ok 1 - readable is a directory' ); test_diag( 'file [readable] exists but is not a directory' ); test_fail(+1); dir_exists_ok( 'readable' ); test_test(); test_out( 'ok 1 - directory sub_dir contains file subdir_file' ); test_out( 'ok 2 - directory sub_dir really contains file subdir_file' ); dir_contains_ok( 'sub_dir', 'subdir_file' ); dir_contains_ok( 'sub_dir', 'subdir_file', 'directory sub_dir really contains file subdir_file' ); test_test(); test_out( 'not ok 1 - directory bmoogle contains file subdir_file' ); test_diag( 'directory [bmoogle] does not exist' ); test_fail(+1); dir_contains_ok( 'bmoogle', 'subdir_file' ); test_test(); test_out( 'not ok 1 - directory sub_dir contains file bmoogle' ); test_diag( 'file [bmoogle] does not exist in directory sub_dir' ); test_fail(+1); dir_contains_ok( 'sub_dir', 'bmoogle' ); test_test(); done_testing(); ��obviously_non_multi_user.t��0000644��00000003033�15125143407�0012107 0��ustar�00��use Test::More 1; BEGIN { our $getpwuid_should_die = 0; our $getgrgid_should_die = 0; }; BEGIN{ no warnings; CORE::GLOBAL::getpwuid = sub ($) { die "Fred" if $getpwuid_should_die }; CORE::GLOBAL::getgrgid = sub ($) { die "Barney" if $getgrgid_should_die }; } use_ok( 'Test::File' ); ok( defined &{ "Test::File::_obviously_non_multi_user" }, "_win32 defined" ); # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # The ones that we know aren't multi-user subtest macos_single_user => sub { local $^O = 'MacOS'; ok( Test::File::_obviously_non_multi_user(), "Returns false for MacOS" ); }; subtest dos_single_user => sub { local $^O = 'dos'; ok( Test::File::_obviously_non_multi_user(), "Returns true for Win32" ); }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # The ones that use get, but die subtest getpwuid_should_die => sub { local $^O = 'Fooey'; $getpwuid_should_die = 1; $getgrgid_should_die = 0; ok( Test::File::_obviously_non_multi_user(), 'getpwuid dying returns true' ); }; subtest getgrgid_should_die => sub { local $^O = 'Fooey'; $getpwuid_should_die = 0; $getgrgid_should_die = 1; ok( Test::File::_obviously_non_multi_user(), 'getgrgid dying returns true' ); }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # The ones that use get, but don't die subtest nothing_dies => sub { local $^O = 'Fooey'; $getpwuid_should_die = 0; $getgrgid_should_die = 0; ok( ! Test::File::_obviously_non_multi_user(), 'getpwuid dying returns true' ); }; done_testing(); ��link_counts.t��0000644��00000004746�15125143407�0007276 0��ustar�00��use strict; use Test::Builder::Tester; use Test::More 1; use_ok( 'Test::File' ); require "./t/setup_common"; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Subroutines are defined subtest defined_subs => sub { my @subs = qw( link_count_is_ok link_count_gt_ok link_count_lt_ok ); foreach my $sub ( @subs ) { no strict 'refs'; ok( defined &{$sub}, "$sub is defined" ); } }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Stuff that should work (single link) my $test_name = "This is my test name"; my $readable = 'readable'; my $readable_sym = 'readable_sym'; my $not_there = 'not_there'; my $dangle_sym = 'dangle_sym'; subtest should_work => sub { test_out( "ok 1 - $test_name" ); test_out( "ok 2 - readable has a link count of [100]" ); test_out( "ok 3 - $test_name" ); test_out( "ok 4 - readable has a link count of [0]" ); test_out( "ok 5 - $test_name" ); link_count_lt_ok( $readable, 100, $test_name ); link_count_lt_ok( $readable, 100 ); link_count_gt_ok( $readable, 0, $test_name ); link_count_gt_ok( $readable, 0 ); link_count_is_ok( $readable, 1, $test_name ); test_test(); test_out( "ok 1 - $readable has a link count of [1]" ); link_count_is_ok( $readable, 1 ); test_test(); done_testing(); }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Stuff that should work (multipe links) # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # Stuff that should fail (missing file) # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # subtest bad_count => sub { test_out( "not ok 1 - $test_name" ); test_diag( "file [$readable] points has [1] links: expected [100]\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+5) . "." ); link_count_is_ok( $readable, 100, $test_name ); test_test(); test_out( "not ok 1 - $test_name" ); test_diag( "file [$readable] points has [1] links: expected less than [0]\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+5) . "." ); link_count_lt_ok( $readable, 0, $test_name ); test_test(); test_out( "not ok 1 - $test_name" ); test_diag( "file [readable] points has [1] links: expected more than [100]\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+5) . "." ); link_count_gt_ok( $readable, 100, $test_name ); test_test(); done_testing(); }; done_testing(); ��file_mtime.t��0000644��00000006031�15125143407�0007045 0��ustar�00��use warnings; use strict; use Test::Builder::Tester; use Test::More 1; use Test::File; require "./t/setup_common"; # Setup test env my $mtime_file = 'mtime_file'; ok( -e $mtime_file, 'mtime file exists ok' ) or die $!; my $curtime = time(); subtest utime => sub { my $set_mtime = $curtime-6010; # 10 minutes ago my $count = utime($set_mtime,$set_mtime,$mtime_file); ok( $count, 'utime reports it set mtime' ) or diag explain $count; my $mtime = ( stat($mtime_file) )[9]; ok( $mtime == $set_mtime, 'utime successfully set mtime for testing' ) or diag "Got: $mtime, Expected: $set_mtime"; }; # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # subtest file_mtime_age_ok => sub { test_out( 'ok 1 - file_mtime_age_ok success' ); test_out( 'ok 2 - mtime_file mtime within 660 seconds of current time' ); file_mtime_age_ok( $mtime_file, 6011, 'file_mtime_age_ok success' ); file_mtime_age_ok( $mtime_file, 6011 ); test_test( 'file_mtime_age_ok success works' ); test_out( 'not ok 1 - mtime_file mtime within 0 seconds of current time' ); file_mtime_age_ok( $mtime_file ); test_test( name => 'file_mtime_age_ok success works', skip_err => 1 ); test_out( 'not ok 1 - file_mtime_age_ok failure' ); test_err( qr/\s#\sfile \[$mtime_file\] [^\n]+\n/ ); test_fail(+1); file_mtime_age_ok( $mtime_file, 609, 'file_mtime_age_ok failure' ); test_test( 'file_mime_age_ok failure works' ); done_testing(); }; subtest file_mtime_lt_ok => sub { my $time = time() + 10; test_out( 'ok 1 - file_mtime_lt_ok success' ); test_out( 'ok 2 - mtime_file mtime less than unix timestamp ' . $time ); file_mtime_lt_ok( $mtime_file, $time, 'file_mtime_lt_ok success' ); file_mtime_lt_ok( $mtime_file, $time ); test_test( 'file_mtime_lt_ok success works' ); test_out( 'not ok 1 - file_mtime_lt_ok failure' ); test_err( qr/\s#\sfile \[$mtime_file\] [^\n]+\n/ ); test_fail(+1); file_mtime_lt_ok( $mtime_file, $curtime-6011, 'file_mtime_lt_ok failure' ); test_test( 'file_mtime_lt_ok failure works' ); done_testing(); }; subtest file_mtime_gt_ok => sub { test_out( 'ok 1 - file_mtime_gt_ok success' ); test_out( 'ok 2 - mtime_file mtime is greater than unix timestamp ' . ($curtime-6011) ); file_mtime_gt_ok( $mtime_file, $curtime-6011, 'file_mtime_gt_ok success' ); file_mtime_gt_ok( $mtime_file, $curtime-6011 ); test_test( 'file_mtime_gt_ok success works' ); test_out( 'not ok 1 - file_mtime_gt_ok failure' ); test_err( qr/\s#\sfile \[$mtime_file\] [^\n]+\n/ ); test_fail( +1 ); file_mtime_gt_ok( $mtime_file, $curtime-609, 'file_mtime_gt_ok failure' ); test_test( 'file_mtime_gt_ok failure works' ); done_testing(); }; subtest _stat_file => sub { # Test internal _stat_file function test_err( qr/\s#\sfile \[.?\] does not exist\n/ ); Test::File::_stat_file( 'non-existent-file-12345', 9 ); test_test( '_stat_file on non-existent file works' ); test_err( qr/\s#\sfile name not specified\n/ ); Test::File::_stat_file( undef ); test_test( '_stat_file no file provided works' ); done_testing(); }; done_testing(); ��setup_common��0000644��00000003622�15125143407�0007204 0��ustar�00��use strict; use Test::More 1; END{ done_testing() unless caller } use Config; use File::Temp qw(tempdir); sub is_cygwin () { scalar grep { lc($^O) eq $_ or lc($Config{osname}) eq $_ } qw( cygwin ) } sub is_msys () { scalar grep { lc($^O) eq $_ or lc($Config{osname}) eq $_ } qw( msys msys2 ) } sub is_win32 () { $^O eq 'MSWin32' } sub is_unix_superuser () { ( not is_win32() and ( $> == 0 or $< == 0 ) ) or ( is_cygwin() and grep { $_ == 544 } split /\s+/, `/usr/bin/id -G` ) } my $dir = tempdir( CLEANUP => 0 ) or BAIL_OUT( "Could not setup temp directory" ); print "Temp dir in <$dir>\n"; unless( -d $dir ) { mkdir 'test_files', 0700 or BAIL_OUT( "Could not make directory! $!" ); } chdir $dir or BAIL_OUT( "Could not change directory! $!" ); my @files = qw( max_file non_zero_file not_readable readable zero_file executable min_file not_executable not_writable writable mtime_file ); foreach my $file ( @files ) { open FH, "> $file"; close FH; } { my $count = chmod 0644, @files; is( $count, scalar @files ) or BAIL_OUT( "Could not make files readable" ); } { my $count = chmod 0400, 'readable', 'not_writable', 'not_executable'; is( $count, 3 ) or BAIL_OUT( "Could not make files readable" ); } { my $count = chmod 0200, 'writable', 'not_readable', 'zero_file', 'max_file', 'non_zero_file'; is( $count, 5 ) or BAIL_OUT( "Could not make files writable" ); if( is_win32() ) { system 'attrib', '+', 'not_readable'; } } { my $count = chmod 0100, 'executable'; is( $count, 1 ) or BAIL_OUT( "Could not make files executable" ); } truncate 'zero_file', 0; truncate 'max_file', 10; truncate 'min_file', 0; { open FH, '> min_file' or BAIL_OUT( "Could not write to min_file: $!" ); binmode FH; #, Windows, yo! print FH 'x' x 40, $/, 'x' x 11, $/; close FH; } is( -s 'min_file', 51 + 2 * length( $/ ) ); mkdir 'sub_dir', 0755 or BAIL_OUT( "Could not cerate subdir: $!" ); ��links.t��0000644��00000012355�15125143407�0006061 0��ustar�00��use strict; use Test::Builder::Tester; use Test::More 1; use Test::File; my $can_symlink = Test::File::has_symlinks(); plan skip_all => "This system doesn't do symlinks" unless $can_symlink; require "./t/setup_common"; subtest dont_work_with_symlinks => sub { no warnings 'redefine'; local Test::File::_no_symlinks_here = sub { 1 }; my @subs = qw( file_is_symlink_ok symlink_target_exists_ok symlink_target_dangles_ok symlink_target_is ); foreach my $sub ( @subs ) { no strict 'refs'; ok( defined &{$sub}, "$sub is defined" ); } foreach my $sub ( @subs ) { no strict 'refs'; test_out("ok 1 # skip $sub doesn't work on systems without symlinks"); &{$sub}(); test_test(); } done_testing(); }; my $test_name = "This is my test name"; my $readable = 'readable'; my $readable_sym = 'readable_sym'; my $not_there = 'not_there'; my $dangle_sym = 'dangle_sym'; my $s = ! $can_symlink ? "# skip file_is_symlink_ok doesn't work on systems without symlinks" : "- $readable_sym is a symlink"; subtest should_work => sub { file_exists_ok( $readable ); file_not_exists_ok( $readable_sym ); if( $can_symlink ) { symlink( $readable, $readable_sym ); open my($fh), ">", $not_there; close $fh; file_exists_ok( $not_there ); symlink( $not_there, $dangle_sym ); file_exists_ok( $readable_sym ); file_exists_ok( $dangle_sym ); file_is_symlink_ok( $dangle_sym ); unlink $not_there or fail( $! ); ok( ! -e $not_there, "$not_there has been removed" ); file_is_symlink_ok( $dangle_sym ); } else { pass(); } test_out( "ok 1 $s" ); file_is_symlink_ok( $readable_sym ); test_test(); test_out( "ok 1 - $test_name" ); file_is_symlink_ok( $readable_sym, $test_name ); test_test(); test_out( "ok 1 - $test_name" ); symlink_target_dangles_ok( $dangle_sym, $test_name ); test_test(); test_out( "ok 1 - $test_name" ); symlink_target_exists_ok( $readable_sym, $readable, $test_name ); test_test(); test_out( "ok 1 $s\n ok 2 - $test_name" ); symlink_target_exists_ok( $readable_sym, $readable ); symlink_target_is( $readable_sym, $readable, $test_name ); test_test(); done_testing(); }; subtest should_work => sub { ok( ! -l $readable, "$readable is not a symlink" ); ok( ! -l $not_there, "$not_there is not a symlink" ); test_out( "not ok 1 - $test_name" ); test_diag( "file [$readable] is not a symlink\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+5) . "." ); file_is_symlink_ok( $readable, $test_name ); test_test(); test_out( "not ok 1 - $test_name" ); test_diag( "file [$not_there] is not a symlink\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+5) . "." ); file_is_symlink_ok( $not_there, $test_name ); test_test(); test_out( "not ok 1 - $test_name" ); test_diag( "file [$not_there] is not a symlink\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+5) . "." ); symlink_target_dangles_ok( $not_there, $test_name ); test_test(); test_out( "not ok 1 - $test_name" ); test_diag( "file [$readable] is not a symlink\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+5) . "." ); symlink_target_is( $readable, $readable_sym, $test_name ); test_test(); test_out( "not ok 1 - $readable is a symlink" ); test_diag( "file [$readable] is not a symlink\n" . " # Failed test '$readable is a symlink'\n" . " # at $0 line " . line_num(+5) . "." ); symlink_target_exists_ok( $readable ); test_test(); done_testing(); }; subtest bad_target_does_not_exist => sub { test_out( "not ok 1 $s" ); test_diag( "symlink [$readable_sym] points to non-existent target [$not_there]\n" . " # Failed test '$readable_sym is a symlink'\n" . " # at $0 line " . line_num(+5) . "." ); symlink_target_exists_ok( $readable_sym, $not_there ); test_test(); test_out( "not ok 1 - symlink $readable_sym points to $not_there" ); test_diag( " Failed test 'symlink $readable_sym points to $not_there'\n" . " # at $0 line " . line_num(+6) . ".\n" . " # got: $readable\n" . " # expected: $not_there" ); symlink_target_is( $readable_sym, $not_there ); test_test(); done_testing(); }; subtest bad_target_does_exists => sub { test_out( "not ok 1 $s" ); test_diag( "symlink [readable_sym] points to\n" . " # got: readable\n" . " # expected: writable\n" . " # Failed test 'readable_sym is a symlink'\n" . " # at $0 line " . line_num(+7) . "." ); symlink_target_exists_ok( $readable_sym, "writable" ); test_test(); done_testing(); }; subtest dangling_exists => sub { test_out( "not ok 1 - $test_name" ); test_out( "not ok 2 - readable_sym is a symlink" ); test_diag( "symlink [$readable_sym] points to existing file [$readable] but shouldn't\n" . " # Failed test '$test_name'\n" . " # at $0 line " . line_num(+10) . "." ); test_diag( "symlink [$readable_sym] points to existing file [$readable] but shouldn't\n" . " # Failed test 'readable_sym is a symlink'\n" . " # at $0 line " . line_num(+6) . "." ); symlink_target_dangles_ok( $readable_sym, $test_name ); symlink_target_dangles_ok( $readable_sym ); test_test(); done_testing(); }; done_testing(); ��line_counters.t��0000644��00000012322�15125143407�0007604 0��ustar�00��use strict; use Test::Builder::Tester; use Test::More 1; use Test::File; require "./t/setup_common"; subtest subs_defined => sub { my @subs = qw( file_line_count_between file_line_count_is file_line_count_isnt ); foreach my $sub ( @subs ) { no strict 'refs'; ok( defined &{$sub}, "$sub is defined" ); } done_testing(); }; my $file = 'min_file'; file_exists_ok( $file ); my @lines = do { local @ARGV = $file; <> }; cmp_ok( scalar @lines, ">", 1, "$file has at least one line" ); my $lines = @lines; my $linesm = $lines - 1; my $linesp = $lines + 1; subtest should_work => sub { test_out( "ok 1 - $file line count is between [$linesm] and [$linesp] lines" ); file_line_count_between( $file, $linesm, $linesp ); test_test(); test_out( "ok 1 - $file line count is between [$lines] and [$linesp] lines" ); file_line_count_between( $file, $lines, $linesp ); test_test(); test_out( "ok 1 - $file line count is between [$lines] and [$lines] lines" ); file_line_count_between( $file, $lines, $lines ); test_test(); test_out( "ok 1 - $file line count is $lines lines" ); file_line_count_is( $file, $lines ); test_test(); test_out( "ok 1 - $file line count is not $linesp lines" ); file_line_count_isnt( $file, $linesp ); test_test(); done_testing(); }; subtest missing_file => sub { my $missing = 'not_there'; file_not_exists_ok( $missing ); test_out( "not ok 1 - $missing line count is between [$linesm] and [$linesp] lines" ); test_diag( "file [$missing] does not exist\n" . " # Failed test '$missing line count is between [$linesm] and [$linesp] lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_between( $missing, $linesm, $linesp ); test_test(); test_out( "not ok 1 - $missing line count is between [$lines] and [$linesp] lines" ); test_diag( "file [$missing] does not exist\n" . " # Failed test '$missing line count is between [$lines] and [$linesp] lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_between( $missing, $lines, $linesp ); test_test(); test_out( "not ok 1 - $missing line count is between [$lines] and [$lines] lines" ); test_diag( "file [$missing] does not exist\n" . " # Failed test '$missing line count is between [$lines] and [$lines] lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_between( $missing, $lines, $lines ); test_test(); test_out( "not ok 1 - $missing line count is $lines lines" ); test_diag( "file [$missing] does not exist\n" . " # Failed test '$missing line count is $lines lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_is( $missing, $lines ); test_test(); test_out( "not ok 1 - $missing line count is not $lines lines" ); test_diag( "file [$missing] does not exist\n" . " # Failed test '$missing line count is not $lines lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_isnt( $missing, $lines ); test_test(); done_testing(); }; subtest missing_line_count => sub { my $file = 'min_file'; file_exists_ok( $file ); test_out( "not ok 1 - $file line count is between [] and [] lines" ); test_diag( "file_line_count_between expects positive whole numbers for the second and third arguments. Got [] and []\n" . " # Failed test '$file line count is between [] and [] lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_between( $file ); test_test(); test_out( "not ok 1 - $file line count is lines" ); test_diag( "file_line_count_is expects a positive whole number for the second argument. Got []\n" . " # Failed test '$file line count is lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_is( $file ); test_test(); test_out( "not ok 1 - $file line count is not lines" ); test_diag( "file_line_count_is expects a positive whole number for the second argument. Got []\n" . " # Failed test '$file line count is not lines'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_isnt( $file ); test_test(); done_testing(); }; subtest wrong_number => sub { my $name = "$file line count is $linesp lines"; test_out( "not ok 1 - $name" ); test_diag( "expected [3] lines in [$file], got [$lines] lines\n" . " # Failed test '$name'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_is( $file, $linesp ); test_test(); test_out( "ok 1 - $file line count is not $linesp lines" ); file_line_count_isnt( $file, $linesp ); test_test(); $name = "$file line count is not $lines lines"; test_out( "not ok 1 - $name" ); test_diag( "expected something other than [$lines] lines in [$file], but got [$lines] lines\n" . " # Failed test '$name'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_isnt( $file, $lines ); test_test(); my $linespp = $linesp + 1; $name = "$file line count is between [$linesp] and [$linespp] lines"; test_out( "not ok 1 - $name" ); test_diag( "expected a line count between [$linesp] and [$linespp] in [$file], but got [$lines] lines\n" . " # Failed test '$name'\n" . " # at $0 line " . line_num(+5) . "." ); file_line_count_between( $file, $linesp, $linespp ); test_test(); done_testing(); }; done_testing(); ��dm_skeleton.t��0000644��00000003016�15125143407�0007237 0��ustar�00��use strict; use Test::Builder::Tester; use Test::More 1; use Test::File; require "./t/setup_common"; subtest setup => sub { ok( defined &Test::File::_dm_skeleton, "_dm_skeleton is defined" ); }; my $readable = 'readable'; my $not_there = 'not_there'; my $test_name = 'This is my test name'; subtest fake_non_multi_user_dm_skeleton => sub { local $^O = 'dos'; ok( Test::File::_obviously_non_multi_user(), "Is not multi user" ); is( Test::File::_dm_skeleton(), 'skip', "Skip on single user systems" ); is( Test::File::_dm_skeleton($readable), 'skip', "Skip on single user systems" ); is( Test::File::_dm_skeleton($not_there), 'skip', "Skip on single user systems" ); }; subtest fake_non_multi_user => sub { local $^O = 'MSWin32'; diag "$^O\n";; ok( ! Test::File::_obviously_non_multi_user(), "Is multi user" ); }; subtest fake_non_multi_user_missing_file => sub { local $^O = 'MSWin32'; ok( ! Test::File::_obviously_non_multi_user(), "Is multi user" ); test_out( "not ok 1" ); test_diag( "file [$not_there] does not exist\n" . " # Failed test at $0 line " . line_num(+4) . "." ); Test::File::_dm_skeleton( $not_there ); test_test(); done_testing(); }; subtest fake_non_multi_user_empty => sub { local $^O = 'MSWin32'; ok( ! Test::File::_obviously_non_multi_user(), "Is multi user" ); test_out( "not ok 1" ); test_diag( "file name not specified\n" . " # Failed test at $0 line " . line_num(+4) . "." ); Test::File::_dm_skeleton(); test_test(); done_testing(); }; done_testing(); ��test_manifest��0000644��00000000432�15125143407�0007335 0��ustar�00��load.t pod.t pod_coverage.t normalize.t dm_skeleton.t win32.t obviously_non_multi_user.t test_files.t test_dirs.t links.t link_counts.t line_counters.t file_sizes.t file_contains.t file_contains_encoded.t file_contains_utf8.t file_mtime.t owner.t rt/30346.t file_contains_encoded.t ��pod_coverage.t��0000644��00000000241�15125143407�0007365 0��ustar�00��use Test::More; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; all_pod_coverage_ok(); ��25-cap-fork.t��0000644��00000002370�15125143504�0006661 0��ustar�00��# By Yary Hluchan with portions copied from David Golden # Copyright (c) 2015 assigned by Yary Hluchan to David Golden. # All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/next_fd/; use Capture::Tiny 'capture'; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; if ( $no_fork ) { plan skip_all => 'tee() requires fork'; } else { plan 'no_plan'; } my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; my $fd = next_fd; my ($stdout, $stderr, @result) = capture { if (!defined(my $child = fork)) { die "fork() failed" } elsif ($child == 0) { print "Happiness"; print STDERR "Certainty\n"; exit; } else { wait; print ", a parent-ly\n"; } return qw(a b c); }; is ( $stdout, "Happiness, a parent-ly\n", "got stdout"); is ( $stderr, "Certainty\n", "got stderr"); is ( "@result", "a b c" , "got result"); is ( next_fd, $fd, "no file descriptors leaked" ); exit 0; ��06-stdout-closed.t��0000644��00000002003�15125143504�0007740 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/save_std restore_std next_fd/; use Cases qw/run_test/; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; plan 'no_plan'; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; save_std(qw/stdout/); ok( close STDOUT, "closed STDOUT" ); my $fd = next_fd; run_test($_) for qw( capture capture_scalar capture_stdout capture_stderr capture_merged ); if ( ! $no_fork ) { run_test($_) for qw( tee tee_scalar tee_stdout tee_stderr tee_merged ); } is( next_fd, $fd, "no file descriptors leaked" ); restore_std(qw/stdout/); exit 0; ��19-relayering.t��0000644��00000004722�15125143504�0007326 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/next_fd sig_num/; use Capture::Tiny ':all'; unless ( PerlIO->can('get_layers') ) { plan skip_all => "Requires PerlIO::getlayers"; } plan 'no_plan'; local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # no timeouts my $builder = Test::More->builder; binmode( $builder->failure_output, ':utf8' ) if $] >= 5.008; my $fd = next_fd; my ( $out, $err, $res, @res, %before, %inner, %outer ); sub _set_layers { my ($fh, $new_layers) = @_; # eliminate pseudo-layers binmode( $fh, ":raw" ) or die "can't binmode $fh"; # strip off real layers until only :unix is left while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) { binmode( $fh, ":pop" ) or die "can't binmode $fh"; } binmode($fh, $new_layers); } sub _get_layers { return ( stdout => [ PerlIO::get_layers( STDOUT, output => 1 ) ], stderr => [ PerlIO::get_layers( STDERR, output => 1 ) ], ); } sub _cmp_layers { local $Test::Builder::Level = $Test::Builder::Level + 1; my ($got, $exp, $label) = @_; ($got, $exp) = map { ":" . join(":", @$_) } $got, $exp; is( $got, $exp, $label ); } #--------------------------------------------------------------------------# # relayer should duplicate layers #--------------------------------------------------------------------------# _set_layers( \STDOUT, ":unix:encoding(UTF-8):encoding(UTF-8):crlf" ); _set_layers( \STDERR, ":unix:encoding(UTF-8):encoding(UTF-8):crlf" ); %before = _get_layers(); ( $out, $err, @res ) = capture { %inner = _get_layers(); print STDOUT "foo\n"; print STDERR "bar\n"; }; %outer = _get_layers(); _cmp_layers( $inner{$_}, $before{$_}, "$_: layers inside capture match previous" ) for qw/stdout stderr/; _cmp_layers( $outer{$_}, $before{$_}, "$_: layers after capture match previous" ) for qw/stdout stderr/; #--------------------------------------------------------------------------# # finish #--------------------------------------------------------------------------# is( next_fd, $fd, "no file descriptors leaked" ); exit 0; # vim: set ts=4 sts=4 sw=4 et tw=75: ��11-stderr-string.t��0000644��00000002223�15125143504�0007756 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/save_std restore_std next_fd/; use Cases qw/run_test/; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; plan skip_all => "In memory files require Perl 5.8" if $] < 5.008; plan 'no_plan'; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; save_std(qw/stderr/); ok( close STDERR, "closed STDERR" ); ok( open( STDERR, ">", \(my $stderr_buf)), "reopened STDERR to string" ); my $fd = next_fd; run_test($_) for qw( capture capture_scalar capture_stdout capture_stderr capture_merged ); if ( ! $no_fork ) { run_test($_) for qw( tee tee_scalar tee_stdout tee_stderr tee_merged ); } is( next_fd, $fd, "no file descriptors leaked" ); restore_std(qw/stderr/); exit 0; ��10-stdout-string.t��0000644��00000002224�15125143504�0007775 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/save_std restore_std next_fd/; use Cases qw/run_test/; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; plan skip_all => "In memory files require Perl 5.8" if $] < 5.008; plan 'no_plan'; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; save_std(qw/stdout/); ok( close STDOUT, "closed STDOUT" ); ok( open( STDOUT, ">", \(my $stdout_buf)), "reopened STDOUT to string" ); my $fd = next_fd; run_test($_) for qw( capture capture_scalar capture_stdout capture_stderr capture_merged ); if ( ! $no_fork ) { run_test($_) for qw( tee tee_scalar tee_stdout tee_stderr tee_merged ); } is( next_fd, $fd, "no file descriptors leaked" ); restore_std(qw/stdout/); exit 0; ��23-all-tied.t��0000644��00000003103�15125143504�0006643 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/save_std restore_std next_fd/; use Cases qw/run_test/; use TieLC; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; plan skip_all => "capture needs Perl 5.8 for tied STDOUT" if $] < 5.008; plan 'no_plan'; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; binmode($builder->todo_output, ':utf8') if $] >= 5.008; save_std(qw/stdout stderr stdin/); tie STDOUT, 'TieLC', ">&=STDOUT"; my $out_tie = tied STDOUT; ok( $out_tie, "STDOUT is tied" ); tie STDERR, 'TieLC', ">&=STDERR"; my $err_tie = tied STDERR; ok( $err_tie, "STDERR is tied" ); tie STDIN, 'TieLC', "<&=STDIN"; my $in_tie = tied STDIN; ok( $in_tie, "STDIN is tied" ); my $fd = next_fd; run_test($_) for qw( capture capture_scalar capture_stdout capture_stderr capture_merged ); if ( ! $no_fork ) { run_test($_) for qw( tee tee_scalar tee_stdout tee_stderr tee_merged ); } is( next_fd, $fd, "no file descriptors leaked" ); is( tied STDOUT, $out_tie, "STDOUT is still tied" ); is( tied STDERR, $err_tie, "STDERR is still tied" ); is( tied STDIN, $in_tie, "STDIN is still tied" ); restore_std(qw/stdout stderr stdin/); exit 0; ��20-stdout-badtie.t��0000644��00000002357�15125143504�0007727 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/save_std restore_std next_fd/; use Cases qw/run_test/; use TieEvil; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; plan skip_all => "capture needs Perl 5.8 for tied STDOUT" if $] < 5.008; plan 'no_plan'; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; binmode($builder->todo_output, ':utf8') if $] >= 5.008; tie STDOUT, 'TieEvil'; my $orig_tie = tied STDOUT; ok( $orig_tie, "STDOUT is tied" ); my $fd = next_fd; run_test($_, '', 'skip_utf8') for qw( capture capture_scalar capture_stdout capture_stderr capture_merged ); if ( ! $no_fork ) { run_test($_, '', 'skip_utf8') for qw( tee tee_scalar tee_stdout tee_stderr tee_merged ); } is( next_fd, $fd, "no file descriptors leaked" ); is( tied STDOUT, $orig_tie, "STDOUT is still tied" ); exit 0; ��01-Capture-Tiny.t��0000644��00000001470�15125143504�0007475 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More 0.62; my @api = qw( capture capture_stdout capture_stderr capture_merged tee tee_stdout tee_stderr tee_merged ); plan tests => 2 + 2 @api; if ( $] eq '5.008' ) { BAIL_OUT("OS unsupported: Perl 5.8.0 is too buggy for Capture::Tiny"); } require_ok( 'Capture::Tiny' ); can_ok('Capture::Tiny', $_) for @api; ok( eval "package Foo; use Capture::Tiny ':all'; 1", "import ':all' to Foo" ); can_ok('Foo', $_) for @api; exit 0; ��13-stdout-tied.t��0000644��00000002405�15125143504�0007420 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/save_std restore_std next_fd/; use Cases qw/run_test/; use TieLC; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; plan skip_all => "capture needs Perl 5.8 for tied STDOUT" if $] < 5.008; plan 'no_plan'; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; binmode($builder->todo_output, ':utf8') if $] >= 5.008; save_std(qw/stdout/); tie STDOUT, 'TieLC', ">&=STDOUT"; my $orig_tie = tied STDOUT; ok( $orig_tie, "STDOUT is tied" ); my $fd = next_fd; run_test($_) for qw( capture capture_scalar capture_stdout capture_stderr capture_merged ); if ( ! $no_fork ) { run_test($_) for qw( tee tee_scalar tee_stdout tee_stderr tee_merged ); } is( next_fd, $fd, "no file descriptors leaked" ); is( tied STDOUT, $orig_tie, "STDOUT is still tied" ); restore_std(qw/stdout/); exit 0; ��24-all-badtied.t��0000644��00000002773�15125143504�0007327 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/save_std restore_std next_fd/; use Cases qw/run_test/; use TieEvil; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; plan skip_all => "capture needs Perl 5.8 for tied STDIN" if $] < 5.008; plan 'no_plan'; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; binmode($builder->todo_output, ':utf8') if $] >= 5.008; tie STDIN, 'TieEvil'; my $in_tie = tied STDIN; ok( $in_tie, "STDIN is tied" ); tie STDOUT, 'TieEvil'; my $out_tie = tied STDOUT; ok( $out_tie, "STDIN is tied" ); tie STDERR, 'TieEvil'; my $err_tie = tied STDERR; ok( $err_tie, "STDIN is tied" ); my $fd = next_fd; run_test($_, '', 'skip_utf8') for qw( capture capture_scalar capture_stdout capture_stderr capture_merged ); if ( ! $no_fork ) { run_test($_, '', 'skip_utf8') for qw( tee tee_scalar tee_stdout tee_stderr tee_merged ); } is( next_fd, $fd, "no file descriptors leaked" ); is( tied STDIN, $in_tie, "STDIN is still tied" ); is( tied STDOUT, $out_tie, "STDOUT is still tied" ); is( tied STDERR, $err_tie, "STDERR is still tied" ); exit 0; ��17-pass-results.t��0000644��00000005152�15125143504�0007626 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use IO::Handle; use Utils qw/next_fd sig_num/; use Capture::Tiny ':all'; use Config; plan tests => 12; local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # no timeouts my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; my $fd = next_fd; my ($out, $err, $res, @res); #--------------------------------------------------------------------------# # capture to array #--------------------------------------------------------------------------# ($out, $err, @res) = capture { print STDOUT "foo\n"; print STDERR "bar\n"; return qw/one two three/; }; is( $out, "foo\n", "capture -> STDOUT captured" ); is( $err, "bar\n", "capture -> STDERR captured" ); is_deeply( \@res, [qw/one two three/], "return values -> array" ); #--------------------------------------------------------------------------# # capture to scalar #--------------------------------------------------------------------------# ($out, $err, $res) = capture { print STDOUT "baz\n"; print STDERR "bam\n"; return qw/one two three/; }; is( $out, "baz\n", "capture -> STDOUT captured" ); is( $err, "bam\n", "capture -> STDERR captured" ); is( $res, "one", "return value -> scalar" ); #--------------------------------------------------------------------------# # capture_stdout to array #--------------------------------------------------------------------------# ($out, @res) = capture_stdout { print STDOUT "foo\n"; return qw/one two three/; }; is( $out, "foo\n", "capture_stdout -> STDOUT captured" ); is_deeply( \@res, [qw/one two three/], "return values -> array" ); #--------------------------------------------------------------------------# # capture_merged to array #--------------------------------------------------------------------------# ($out, $res) = capture_merged { print STDOUT "baz\n"; print STDERR "bam\n"; return qw/one two three/; }; like( $out, qr/baz/, "capture_merged -> STDOUT captured" ); like( $out, qr/bam/, "capture_merged -> STDERR captured" ); is( $res, "one", "return value -> scalar" ); #--------------------------------------------------------------------------# # finish #--------------------------------------------------------------------------# is( next_fd, $fd, "no file descriptors leaked" ); exit 0; ��12-stdin-string.t��0000644��00000002574�15125143504�0007606 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/save_std restore_std next_fd/; use Cases qw/run_test/; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; plan skip_all => "In memory files require Perl 5.8" if $] < 5.008; plan 'no_plan'; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; #--------------------------------------------------------------------------# # pre-load PerlIO::scalar to avoid it opening on FD 0; c.f. # http://www.nntp.perl.org/group/perl.perl5.porters/2008/07/msg138898.html require PerlIO::scalar; save_std(qw/stdin/); ok( close STDIN, "closed STDIN" ); ok( open( STDIN, "<", \(my $stdin_buf)), "reopened STDIN to string" ); my $fd = next_fd; run_test($_) for qw( capture capture_scalar capture_stdout capture_stderr capture_merged ); if ( ! $no_fork ) { run_test($_) for qw( tee tee_scalar tee_stdout tee_stderr tee_merged ); } is( next_fd, $fd, "no file descriptors leaked" ); restore_std(qw/stdin/); exit 0; ��18-custom-capture.t��0000644��00000011025�15125143504�0010131 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use IO::Handle; use IO::File; use File::Temp qw/tmpnam/; use Utils qw/next_fd sig_num/; use Capture::Tiny ':all'; use Config; plan tests => 19; local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # no timeouts my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; my $fd = next_fd; my ($out, $err, $res, @res); #--------------------------------------------------------------------------# # capture to custom IO::File #--------------------------------------------------------------------------# my $temp_out = tmpnam(); my $temp_err = tmpnam(); ok( !-e $temp_out, "Temp out '$temp_out' doesn't exist" ); ok( !-e $temp_err, "Temp out '$temp_err' doesn't exist" ); my $out_fh = IO::File->new($temp_out, "w+"); my $err_fh = IO::File->new($temp_err, "w+"); capture { print STDOUT "foo\n"; print STDERR "bar\n"; } stdout => $out_fh, stderr => $err_fh; $out_fh->close; $err_fh->close; is( scalar do {local (@ARGV,$/) = $temp_out; <>} , "foo\n", "captured STDOUT to custom handle (IO::File)" ); is( scalar do {local (@ARGV,$/) = $temp_err; <>} , "bar\n", "captured STDERR to custom handle (IO::File)" ); unlink $_ for $temp_out, $temp_err; #--------------------------------------------------------------------------# # capture to GLOB handle #--------------------------------------------------------------------------# $temp_out = tmpnam(); $temp_err = tmpnam(); ok( !-e $temp_out, "Temp out '$temp_out' doesn't exist" ); ok( !-e $temp_err, "Temp out '$temp_err' doesn't exist" ); open $out_fh, "+>", $temp_out; open $err_fh, "+>", $temp_err; capture { print STDOUT "foo\n"; print STDERR "bar\n"; } stdout => $out_fh, stderr => $err_fh; $out_fh->close; $err_fh->close; is( scalar do {local (@ARGV,$/) = $temp_out; <>} , "foo\n", "captured STDOUT to custom handle (GLOB)" ); is( scalar do {local (@ARGV,$/) = $temp_err; <>} , "bar\n", "captured STDERR to custom handle (GLOB)" ); unlink $_ for $temp_out, $temp_err; #--------------------------------------------------------------------------# # append to custom IO::File #--------------------------------------------------------------------------# $temp_out = tmpnam(); $temp_err = tmpnam(); ok( !-e $temp_out, "Temp out '$temp_out' doesn't exist" ); ok( !-e $temp_err, "Temp out '$temp_err' doesn't exist" ); $out_fh = IO::File->new($temp_out, "w+"); $err_fh = IO::File->new($temp_err, "w+"); $out_fh->autoflush(1); $err_fh->autoflush(1); print $out_fh "Shouldn't see this in capture\n"; print $err_fh "Shouldn't see this in capture\n"; my ($got_out, $got_err) = capture { print STDOUT "foo\n"; print STDERR "bar\n"; } stdout => $out_fh, stderr => $err_fh; $out_fh->close; $err_fh->close; is( $got_out, "foo\n", "captured appended STDOUT to custom handle" ); is( $got_err, "bar\n", "captured appended STDERR to custom handle" ); unlink $_ for $temp_out, $temp_err; #--------------------------------------------------------------------------# # repeated append to custom IO::File with no output #--------------------------------------------------------------------------# $temp_out = tmpnam(); $temp_err = tmpnam(); ok( !-e $temp_out, "Temp out '$temp_out' doesn't exist" ); ok( !-e $temp_err, "Temp out '$temp_err' doesn't exist" ); $out_fh = IO::File->new($temp_out, "a+"); $err_fh = IO::File->new($temp_err, "a+"); ($got_out, $got_err) = capture { my $i = 0; $i++ for 1 .. 10; # no output, just busywork } stdout => $out_fh, stderr => $err_fh; is( $got_out, "", "Try 1: captured empty appended STDOUT to custom handle" ); is( $got_err, "", "Try 1: captured empty appended STDERR to custom handle" ); ($got_out, $got_err) = capture { my $i = 0; $i++ for 1 .. 10; # no output, just busywork } stdout => $out_fh, stderr => $err_fh; is( $got_out, "", "Try 2: captured empty appended STDOUT to custom handle" ); is( $got_err, "", "Try 2: captured empty appended STDERR to custom handle" ); unlink $_ for $temp_out, $temp_err; #--------------------------------------------------------------------------# # finish #--------------------------------------------------------------------------# close ARGV; # opened by reading from <> is( next_fd, $fd, "no file descriptors leaked" ); exit 0; ��08-stdin-closed.t��0000644��00000003101�15125143504�0007541 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/save_std restore_std next_fd/; use Cases qw/run_test/; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; plan 'no_plan'; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; # XXX work around a bug in perl; this needs to be called early-ish # to avoid some sort of filehandle leak when combined with Capture::Tiny my $qm = quotemeta("\x{263a}"); save_std(qw/stdin/); ok( close STDIN, "closed STDIN" ); my $fd = next_fd; run_test($_) for qw( capture capture_scalar capture_stdout capture_stderr capture_merged ); if ( ! $no_fork ) { # prior to 5.12, PERL_UNICODE=D causes problems when STDIN is closed # before capturing. No idea why. Documented as a known issue. if ( $] lt '5.012' && ${^UNICODE} & 24 ) { diag 'Skipping tee() tests because PERL_UNICODE=D not supported'; } else { run_test($_) for qw( tee tee_scalar tee_stdout tee_stderr tee_merged ); } } if ( $] lt '5.012' && ${^UNICODE} & 24 ) { diag 'Skipping leak test because PERL_UNICODE=D not supported'; } else { is( next_fd, $fd, "no file descriptors leaked" ); } restore_std(qw/stdin/); exit 0; ��16-catch-errors.t��0000644��00000002273�15125143504�0007555 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/next_fd sig_num/; use Capture::Tiny qw/capture tee/; use Config; plan tests => 5; local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # no timeouts my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; my $fd = next_fd; $@ = "initial error"; my ($out, $err) = capture { print "foo\n" }; is( $@, 'initial error', "Initial \$\@ not lost during capture" ); ($out, $err) = capture { eval { tee { local $\|=1; print STDOUT "foo\n"; print STDERR "bar\n"; die "Fatal error in capture\n"; } }; }; my $error = $@; is( $error, "Fatal error in capture\n", "\$\@ preserved after capture" ); is( $out, "foo\n", "STDOUT still captured" ); is( $err, "bar\n", "STDOUT still captured" ); is( next_fd, $fd, "no file descriptors leaked" ); exit 0; ��09-preserve-exit-code.t��0000644��00000001341�15125143504�0010670 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/next_fd sig_num/; use Capture::Tiny qw/capture/; use Config; plan tests => 2; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; my $fd = next_fd; capture { $? = 42; }; is( $?, 42, "\$\? preserved after capture ends" ); is( next_fd, $fd, "no file descriptors leaked" ); exit 0; ��21-stderr-badtie.t��0000644��00000002357�15125143504�0007711 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/save_std restore_std next_fd/; use Cases qw/run_test/; use TieEvil; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; plan skip_all => "capture needs Perl 5.8 for tied STDERR" if $] < 5.008; plan 'no_plan'; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; binmode($builder->todo_output, ':utf8') if $] >= 5.008; tie STDERR, 'TieEvil'; my $orig_tie = tied STDERR; ok( $orig_tie, "STDERR is tied" ); my $fd = next_fd; run_test($_, '', 'skip_utf8') for qw( capture capture_scalar capture_stdout capture_stderr capture_merged ); if ( ! $no_fork ) { run_test($_, '', 'skip_utf8') for qw( tee tee_scalar tee_stdout tee_stderr tee_merged ); } is( next_fd, $fd, "no file descriptors leaked" ); is( tied STDERR, $orig_tie, "STDERR is still tied" ); exit 0; ��14-stderr-tied.t��0000644��00000002406�15125143504�0007403 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/save_std restore_std next_fd/; use Cases qw/run_test/; use TieLC; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; plan skip_all => "capture needs Perl 5.8 for tied STDERR" if $] < 5.008; plan 'no_plan'; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; binmode($builder->todo_output, ':utf8') if $] >= 5.008; save_std(qw/stderr/); tie STDERR, 'TieLC', ">&=STDERR"; my $orig_tie = tied STDERR; ok( $orig_tie, "STDERR is tied" ); my $fd = next_fd; run_test($_) for qw( capture capture_scalar capture_stdout capture_stderr capture_merged ); if ( ! $no_fork ) { run_test($_) for qw( tee tee_scalar tee_stdout tee_stderr tee_merged ); } is( next_fd, $fd, "no file descriptors leaked" ); is( tied STDERR, $orig_tie, "STDERR is still tied" ); restore_std(qw/stderr/); exit 0; ��15-stdin-tied.t��0000644��00000002420�15125143504�0007216 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/save_std restore_std next_fd/; use Cases qw/run_test/; use TieLC; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; plan skip_all => "capture needs Perl 5.8 for tied STDERR" if $] < 5.008; #plan skip_all => "not supported on Windows yet" # if $^O eq 'MSWin32'; plan 'no_plan'; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; save_std(qw/stdin/); tie STDIN, 'TieLC', "<&=STDIN"; my $orig_tie = tied STDIN; ok( $orig_tie, "STDIN is tied" ); my $fd = next_fd; run_test($_) for qw( capture capture_scalar capture_stdout capture_stderr capture_merged ); if ( ! $no_fork ) { run_test($_) for qw( tee tee_scalar tee_stdout tee_stderr tee_merged ); } is( next_fd, $fd, "no file descriptors leaked" ); is( tied STDIN, $orig_tie, "STDIN is still tied" ); restore_std(qw/stdin/); exit 0; ��03-tee.t��0000644��00000001564�15125143504�0005734 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/next_fd/; use Cases qw/run_test/; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; if ( $no_fork ) { plan skip_all => 'tee() requires fork'; } else { plan 'no_plan'; } my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; my $fd = next_fd; run_test('tee'); run_test('tee_scalar'); run_test('tee_stdout'); run_test('tee_stderr'); run_test('tee_merged'); is( next_fd, $fd, "no file descriptors leaked" ); exit 0; ��07-stderr-closed.t��0000644��00000002002�15125143504�0007721 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/save_std restore_std next_fd/; use Cases qw/run_test/; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; plan 'no_plan'; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; save_std(qw/stderr/); ok( close STDERR, "closed STDERR" ); my $fd = next_fd; run_test($_) for qw( capture capture_scalar capture_stdout capture_stderr capture_merged ); if ( ! $no_fork ) { run_test($_) for qw( tee tee_scalar tee_stdout tee_stderr tee_merged ); } is( next_fd, $fd, "no file descriptors leaked" ); restore_std(qw/stderr/); exit 0; ��02-capture.t��0000644��00000001376�15125143504�0006622 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/next_fd/; use Cases qw/run_test/; plan 'no_plan'; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; my $fd = next_fd; run_test('capture'); run_test('capture_scalar'); run_test('capture_stdout'); run_test('capture_stderr'); run_test('capture_merged'); is( next_fd, $fd, "no file descriptors leaked" ); exit 0; ��22-stdin-badtie.t��0000644��00000002351�15125143504�0007522 0��ustar�00��# Copyright (c) 2009 by David Golden. All rights reserved. # Licensed under Apache License, Version 2.0 (the "License"). # You may not use this file except in compliance with the License. # A copy of the License was distributed with this file or you may obtain a # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 use strict; use warnings; use Test::More; use lib 't/lib'; use Utils qw/save_std restore_std next_fd/; use Cases qw/run_test/; use TieEvil; use Config; my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; plan skip_all => "capture needs Perl 5.8 for tied STDIN" if $] < 5.008; plan 'no_plan'; my $builder = Test::More->builder; binmode($builder->failure_output, ':utf8') if $] >= 5.008; binmode($builder->todo_output, ':utf8') if $] >= 5.008; tie STDIN, 'TieEvil'; my $orig_tie = tied STDIN; ok( $orig_tie, "STDIN is tied" ); my $fd = next_fd; run_test($_, '', 'skip_utf8') for qw( capture capture_scalar capture_stdout capture_stderr capture_merged ); if ( ! $no_fork ) { run_test($_, '', 'skip_utf8') for qw( tee tee_scalar tee_stdout tee_stderr tee_merged ); } is( next_fd, $fd, "no file descriptors leaked" ); is( tied STDIN, $orig_tie, "STDIN is still tied" ); exit 0; ��lib/Utils.pm��0000644��00000002175�15125143504�0006755 0��ustar�00��package Utils; use strict; use warnings; use File::Spec; use Config; require Exporter; our @ISA = 'Exporter'; our @EXPORT = qw/save_std restore_std next_fd sig_num/; sub _open { open $_[0], $_[1] or die "Error from open( " . join(q{, }, @_) . "): $!"; } my @saved; sub save_std { for my $h ( @_ ) { my $fh; _open $fh, ($h eq 'stdin' ? "<&" : ">&") . uc $h; push @saved, $fh; } } sub restore_std { for my $h ( @_ ) { no strict 'refs'; my $fh = shift @saved; _open \{uc $h}, ($h eq 'stdin' ? "<&" : ">&") . fileno( $fh ); close $fh; } } sub next_fd { no warnings 'io'; open my $fh, ">", File::Spec->devnull; my $fileno = fileno $fh; close $fh; return $fileno; } #--------------------------------------------------------------------------# my %sig_num; my @sig_name; unless($Config{sig_name} && $Config{sig_num}) { die "No sigs?"; } else { my @names = split ' ', $Config{sig_name}; @sig_num{@names} = split ' ', $Config{sig_num}; foreach (@names) { $sig_name[$sig_num{$_}] \|\|= $_; } } sub sig_num { my $name = shift; return exists $sig_num{$name} ? $sig_num{$name} : ''; } 1; ��lib/TieLC.pm��0000644��00000001460�15125143504�0006611 0��ustar�00��package TieLC; sub TIEHANDLE { my $class = shift; my $fh = \do { local HANDLE}; bless $fh,$class; $fh->OPEN(@_) if (@_); $fh->BINMODE(':utf8'); return $fh; } sub EOF { eof($_[0]) } sub TELL { tell($_[0]) } sub FILENO { fileno($_[0]) } sub SEEK { seek($_[0],$_[1],$_[2]) } sub CLOSE { close($_[0]) } sub BINMODE { binmode($_[0],$_[1]) } sub OPEN { $_[0]->CLOSE if defined($_[0]->FILENO); @_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]); } sub READ { read($_[0],$_[1],$_[2]) } sub READLINE { "hello world\n" } sub GETC { getc($_[0]) } sub WRITE { my $fh = $_[0]; print $fh substr($_[1],0,$_[2]) } sub PRINT { my ($self, @what) = @_; my $buf = lc join('', @what); $self->WRITE($buf, length($buf), 0); } sub UNTIE { 1 }; # suppress warnings about references 1; ��lib/Cases.pm��0000644��00000021601�15125143504�0006706 0��ustar�00��package Cases; use strict; use warnings; use Test::More; use Capture::Tiny ':all'; require Exporter; our @ISA = 'Exporter'; our @EXPORT_OK = qw( run_test ); my $locale_ok = eval { my $err = capture_stderr { system($^X, '-we', 1) }; $err !~ /setting locale failed/i; }; my $have_diff = eval { require Test::Differences; Test::Differences->import; $Test::Differences::VERSION < 0.60; # 0.60+ is causing strange failures }; sub _is_or_diff { my ($g,$e,$l) = @_; if ( $have_diff ) { eq_or_diff( $g, $e, $l ); } else { is( $g, $e, $l ); } } sub _binmode { my $text = shift; return $text eq 'unicode' ? 'binmode(STDOUT,q{:utf8}); binmode(STDERR,q{:utf8});' : ''; } sub _set_utf8 { my $t = shift; return unless $t eq 'unicode'; my %seen; my @orig_layers = ( [ grep {$_ ne 'unix' and $_ ne 'perlio' and $seen{stdout}{$_}++} PerlIO::get_layers(\STDOUT) ], [ grep {$_ ne 'unix' and $_ ne 'perlio' and $seen{stderr}{$_}++} PerlIO::get_layers(\STDERR) ], ); binmode(STDOUT, ":utf8") if fileno(STDOUT); binmode(STDERR, ":utf8") if fileno(STDERR); return @orig_layers; } sub _restore_layers { my ($t, @orig_layers) = @_; return unless $t eq 'unicode'; binmode(STDOUT, join( ":", "", "raw", @{$orig_layers[0]})) if fileno(STDOUT); binmode(STDERR, join( ":", "", "raw", @{$orig_layers[1]})) if fileno(STDERR); } #--------------------------------------------------------------------------# my %texts = ( short => 'Hello World', multiline => 'First line\nSecond line\n', ( $] lt "5.008" ? () : ( unicode => 'Hi! \x{263a}\n') ), ); #--------------------------------------------------------------------------# # fcn($perl_code_string) => execute the perl in current process or subprocess #--------------------------------------------------------------------------# my %methods = ( perl => sub { eval $_[0] }, sys => sub { system($^X, '-e', $_[0]) }, ); #--------------------------------------------------------------------------# my %channels = ( stdout => { output => sub { _binmode($_[0]) . "print STDOUT qq{STDOUT:$texts{$_[0]}}" }, expect => sub { eval "qq{STDOUT:$texts{$_[0]}}", "" }, }, stderr => { output => sub { _binmode($_[0]) . "print STDERR qq{STDERR:$texts{$_[0]}}" }, expect => sub { "", eval "qq{STDERR:$texts{$_[0]}}" }, }, both => { output => sub { _binmode($_[0]) . "print STDOUT qq{STDOUT:$texts{$_[0]}}; print STDERR qq{STDERR:$texts{$_[0]}}" }, expect => sub { eval "qq{STDOUT:$texts{$_[0]}}", eval "qq{STDERR:$texts{$_[0]}}" }, }, empty => { output => sub { _binmode($_[0]) . "print STDOUT qq{}; print STDERR qq{}" }, expect => sub { "", "" }, }, nooutput=> { output => sub { _binmode($_[0]) }, expect => sub { "", "" }, }, ); #--------------------------------------------------------------------------# my %tests = ( capture => { cnt => 2, test => sub { my ($m, $c, $t, $l) = @_; my ($got_out, $got_err) = capture { $methods{$m}->( $channels{$c}{output}->($t) ); }; my @expected = $channels{$c}{expect}->($t); _is_or_diff( $got_out, $expected[0], "$l\|$m\|$c\|$t - got STDOUT" ); _is_or_diff( $got_err, $expected[1], "$l\|$m\|$c\|$t - got STDERR" ); }, }, capture_scalar => { cnt => 1, test => sub { my ($m, $c, $t, $l) = @_; my $got_out = capture { $methods{$m}->( $channels{$c}{output}->($t) ); }; my @expected = $channels{$c}{expect}->($t); _is_or_diff( $got_out, $expected[0], "$l\|$m\|$c\|$t - got STDOUT" ); }, }, capture_stdout => { cnt => 3, test => sub { my ($m, $c, $t, $l) = @_; my ($inner_out, $inner_err); my ($outer_out, $outer_err) = capture { $inner_out = capture_stdout { $methods{$m}->( $channels{$c}{output}->($t) ); }; }; my @expected = $channels{$c}{expect}->($t); _is_or_diff( $inner_out, $expected[0], "$l\|$m\|$c\|$t - inner STDOUT" ); _is_or_diff( $outer_out, "", "$l\|$m\|$c\|$t - outer STDOUT" ); _is_or_diff( $outer_err, $expected[1], "$l\|$m\|$c\|$t - outer STDERR" ); }, }, capture_stderr => { cnt => 3, test => sub { my ($m, $c, $t, $l) = @_; my ($inner_out, $inner_err); my ($outer_out, $outer_err) = capture { $inner_err = capture_stderr { $methods{$m}->( $channels{$c}{output}->($t) ); }; }; my @expected = $channels{$c}{expect}->($t); _is_or_diff( $inner_err, $expected[1], "$l\|$m\|$c\|$t - inner STDERR" ); _is_or_diff( $outer_out, $expected[0], "$l\|$m\|$c\|$t - outer STDOUT" ); _is_or_diff( $outer_err, "", "$l\|$m\|$c\|$t - outer STDERR" ); }, }, capture_merged => { cnt => 2, test => sub { my ($m, $c, $t, $l) = @_; my $got_out = capture_merged { $methods{$m}->( $channels{$c}{output}->($t) ); }; my @expected = $channels{$c}{expect}->($t); like( $got_out, qr/\Q$expected[0]\E/, "$l\|$m\|$c\|$t - got STDOUT" ); like( $got_out, qr/\Q$expected[1]\E/, "$l\|$m\|$c\|$t - got STDERR" ); }, }, tee => { cnt => 4, test => sub { my ($m, $c, $t, $l) = @_; my ($got_out, $got_err); my ($tee_out, $tee_err) = capture { ($got_out, $got_err) = tee { $methods{$m}->( $channels{$c}{output}->($t) ); }; }; my @expected = $channels{$c}{expect}->($t); _is_or_diff( $got_out, $expected[0], "$l\|$m\|$c\|$t - got STDOUT" ); _is_or_diff( $tee_out, $expected[0], "$l\|$m\|$c\|$t - tee STDOUT" ); _is_or_diff( $got_err, $expected[1], "$l\|$m\|$c\|$t - got STDERR" ); _is_or_diff( $tee_err, $expected[1], "$l\|$m\|$c\|$t - tee STDERR" ); } }, tee_scalar => { cnt => 3, test => sub { my ($m, $c, $t, $l) = @_; my ($got_out, $got_err); my ($tee_out, $tee_err) = capture { $got_out = tee { $methods{$m}->( $channels{$c}{output}->($t) ); }; }; my @expected = $channels{$c}{expect}->($t); _is_or_diff( $got_out, $expected[0], "$l\|$m\|$c\|$t - got STDOUT" ); _is_or_diff( $tee_out, $expected[0], "$l\|$m\|$c\|$t - tee STDOUT" ); _is_or_diff( $tee_err, $expected[1], "$l\|$m\|$c\|$t - tee STDERR" ); } }, tee_stdout => { cnt => 3, test => sub { my ($m, $c, $t, $l) = @_; my ($inner_out, $inner_err); my ($tee_out, $tee_err) = capture { $inner_out = tee_stdout { $methods{$m}->( $channels{$c}{output}->($t) ); }; }; my @expected = $channels{$c}{expect}->($t); _is_or_diff( $inner_out, $expected[0], "$l\|$m\|$c\|$t - inner STDOUT" ); _is_or_diff( $tee_out, $expected[0], "$l\|$m\|$c\|$t - teed STDOUT" ); _is_or_diff( $tee_err, $expected[1], "$l\|$m\|$c\|$t - unmodified STDERR" ); } }, tee_stderr => { cnt => 3, test => sub { my ($m, $c, $t, $l) = @_; my ($inner_out, $inner_err); my ($tee_out, $tee_err) = capture { $inner_err = tee_stderr { $methods{$m}->( $channels{$c}{output}->($t) ); }; }; my @expected = $channels{$c}{expect}->($t); _is_or_diff( $inner_err, $expected[1], "$l\|$m\|$c\|$t - inner STDOUT" ); _is_or_diff( $tee_out, $expected[0], "$l\|$m\|$c\|$t - unmodified STDOUT" ); _is_or_diff( $tee_err, $expected[1], "$l\|$m\|$c\|$t - teed STDERR" ); } }, tee_merged => { cnt => 5, test => sub { my ($m, $c, $t, $l) = @_; my ($got_out, $got_err); my ($tee_out, $tee_err) = capture { $got_out = tee_merged { $methods{$m}->( $channels{$c}{output}->($t) ); }; }; my @expected = $channels{$c}{expect}->($t); like( $got_out, qr/\Q$expected[0]\E/, "$l\|$m\|$c\|$t - got STDOUT" ); like( $got_out, qr/\Q$expected[1]\E/, "$l\|$m\|$c\|$t - got STDERR" ); like( $tee_out, qr/\Q$expected[0]\E/, "$l\|$m\|$c\|$t - tee STDOUT (STDOUT)" ); like( $tee_out, qr/\Q$expected[1]\E/, "$l\|$m\|$c\|$t - tee STDOUT (STDERR)" ); _is_or_diff( $tee_err, '', "$l\|$m\|$c\|$t - tee STDERR" ); } }, ); #--------------------------------------------------------------------------# # What I want to be able to do: # # test_it( # input => 'short', # channels => 'both', # method => 'perl' # ) sub run_test { my $test_type = shift or return; my $todo = shift \|\| ''; my $skip_utf8 = shift \|\| ''; local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # don't timeout during testing for my $m ( keys %methods ) { if ( ($m eq 'sys' \|\| substr($test_type,0,3) eq 'tee' ) && ! $locale_ok ) { SKIP: { skip "Perl could not initialize locale", 1 }; next; } for my $c ( keys %channels ) { for my $t ( keys %texts ) { next if $t eq 'unicode' && $skip_utf8; my @orig_layers = _set_utf8($t); local $TODO = "not supported on all platforms" if $t eq $todo; $tests{$test_type}{test}->($m, $c, $t, $test_type); _restore_layers($t, @orig_layers); } } } } 1; ��lib/TieEvil.pm��0000644��00000001332�15125143504�0007210 0��ustar�00��package TieEvil; # FCGI tied with a scalar ref object, which breaks when you # call open on it. Emulate that to test the workaround: use Carp (); sub TIEHANDLE { my $class = shift; my $fh = \(my $scalar); # this is evil and broken return bless $fh,$class; } sub EOF { 0 } sub TELL { length ${$_[0]} } sub FILENO { -1 } sub SEEK { 1 } sub CLOSE { 1 } sub BINMODE { 1 } sub OPEN { Carp::confess "unimplemented" } sub READ { $_[1] = substr(${$_[0]},$_[3],$_[2]) } sub READLINE { "hello world\n" } sub GETC { substr(${$_[0]},0,1) } sub PRINT { my ($self, @what) = @_; my $new = join($\, @what); $$self .= $new; return length $new; } sub UNTIE { 1 }; # suppress warnings about references 1; ��examples.t��0000644��00000002737�15125143560�0006562 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use HTTP::CookieJar; my $req = "http://www.example.com/foo/bar"; my $sreq = "https://www.example.com/foo/bar"; my $jar = new_ok("HTTP::CookieJar"); subtest "just key & value" => sub { $jar->clear; $jar->add( $req, "SID=31d4d96e407aad42" ); is( $jar->cookie_header($req), "SID=31d4d96e407aad42" ); }; subtest "secure" => sub { $jar->clear; $jar->add( $req, "SID=31d4d96e407aad42; Secure" ); $jar->add( $req, "lang=en-US; Path=/; Domain=example.com" ); is( $jar->cookie_header($sreq), "SID=31d4d96e407aad42; lang=en-US" ); is( $jar->cookie_header($req), "lang=en-US" ); }; subtest "not a subdomain" => sub { $jar->clear; $jar->add( $req, "SID=31d4d96e407aad42" ); is( $jar->cookie_header("http://wwww.example.com/foo/baz"), "" ); }; subtest "wrong path" => sub { $jar->clear; $jar->add( $req, "SID=31d4d96e407aad42" ); is( $jar->cookie_header("http://www.example.com/"), "" ); }; subtest "expiration" => sub { $jar->clear; $jar->add( $req, "lang=en-US; Expires=Sun, 09 Jun 2041 10:18:14 GMT" ); is( $jar->cookie_header($req), "lang=en-US" ); $jar->add( $req, "lang=; Expires=Sun, 06 Nov 1994 08:49:37 GMT" ); is( $jar->cookie_header($req), "" ); }; done_testing; # # This file is part of HTTP-CookieJar # # This software is Copyright (c) 2013 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��zzz-lwp.t��0000644��00000053450�15125143560�0006377 0��ustar�00��use 5.008001; use warnings; use Test::More 0.96; use Time::Local; use HTTP::CookieJar::LWP; use Test::Requires qw( HTTP::Request HTTP::Response ); #------------------------------------------------------------------- # First we check that it works for the original example at # http://curl.haxx.se/rfc/cookie_spec.html # Client requests a document, and receives in the response: # # Set-Cookie: CUSTOMER=WILE_E_COYOTE; path=/; expires=Wednesday, 09-Nov-99 23:12:40 GMT # # When client requests a URL in path "/" on this server, it sends: # # Cookie: CUSTOMER=WILE_E_COYOTE # # Client requests a document, and receives in the response: # # Set-Cookie: PART_NUMBER=ROCKET_LAUNCHER_0001; path=/ # # When client requests a URL in path "/" on this server, it sends: # # Cookie: CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001 # # Client receives: # # Set-Cookie: SHIPPING=FEDEX; path=/fo # # When client requests a URL in path "/" on this server, it sends: # # Cookie: CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001 # # When client requests a URL in path "/foo" on this server, it sends: # # Cookie: CUSTOMER=WILE_E_COYOTE; PART_NUMBER=ROCKET_LAUNCHER_0001; SHIPPING=FEDEX # # The last Cookie is buggy, because both specifications says that the # most specific cookie must be sent first. SHIPPING=FEDEX is the # most specific and should thus be first. my $year_plus_one = (localtime)[5] + 1900 + 1; $c = HTTP::CookieJar::LWP->new; $req = HTTP::Request->new( GET => "http://1.1.1.1/" ); $req->header( "Host", "www.acme.com:80" ); $res = HTTP::Response->new( 200, "OK" ); $res->request($req); $res->header( "Set-Cookie" => "CUSTOMER=WILE_E_COYOTE; path=/ ; expires=Wednesday, 09-Nov-$year_plus_one 23:12:40 GMT" ); #; $c->extract_cookies($res); $req = HTTP::Request->new( GET => "http://www.acme.com/" ); $c->add_cookie_header($req); is( $req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE" ) or diag explain $c; $res->request($req); $res->header( "Set-Cookie" => "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/" ); $c->extract_cookies($res); $req = HTTP::Request->new( GET => "http://www.acme.com/foo/bar" ); $c->add_cookie_header($req); $h = $req->header("Cookie"); ok( $h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/ ); ok( $h =~ /CUSTOMER=WILE_E_COYOTE/ ); $res->request($req); $res->header( "Set-Cookie", "SHIPPING=FEDEX; path=/foo" ); $c->extract_cookies($res); $req = HTTP::Request->new( GET => "http://www.acme.com/" ); $c->add_cookie_header($req); $h = $req->header("Cookie"); ok( $h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/ ); ok( $h =~ /CUSTOMER=WILE_E_COYOTE/ ); ok( $h !~ /SHIPPING=FEDEX/ ); $req = HTTP::Request->new( GET => "http://www.acme.com/foo/" ); $c->add_cookie_header($req); $h = $req->header("Cookie"); ok( $h =~ /PART_NUMBER=ROCKET_LAUNCHER_0001/ ); ok( $h =~ /CUSTOMER=WILE_E_COYOTE/ ); ok( $h =~ /^SHIPPING=FEDEX;/ ); # Second Example transaction sequence: # # Assume all mappings from above have been cleared. # # Client receives: # # Set-Cookie: PART_NUMBER=ROCKET_LAUNCHER_0001; path=/ # # When client requests a URL in path "/" on this server, it sends: # # Cookie: PART_NUMBER=ROCKET_LAUNCHER_0001 # # Client receives: # # Set-Cookie: PART_NUMBER=RIDING_ROCKET_0023; path=/ammo # # When client requests a URL in path "/ammo" on this server, it sends: # # Cookie: PART_NUMBER=RIDING_ROCKET_0023; PART_NUMBER=ROCKET_LAUNCHER_0001 # # NOTE: There are two name/value pairs named "PART_NUMBER" due to # the inheritance of the "/" mapping in addition to the "/ammo" mapping. $c = HTTP::CookieJar::LWP->new; # clear it $req = HTTP::Request->new( GET => "http://www.acme.com/" ); $res = HTTP::Response->new( 200, "OK" ); $res->request($req); $res->header( "Set-Cookie", "PART_NUMBER=ROCKET_LAUNCHER_0001; path=/" ); $c->extract_cookies($res); $req = HTTP::Request->new( GET => "http://www.acme.com/" ); $c->add_cookie_header($req); is( $req->header("Cookie"), "PART_NUMBER=ROCKET_LAUNCHER_0001" ); $res->request($req); $res->header( "Set-Cookie", "PART_NUMBER=RIDING_ROCKET_0023; path=/ammo" ); $c->extract_cookies($res); $req = HTTP::Request->new( GET => "http://www.acme.com/ammo" ); $c->add_cookie_header($req); ok( $req->header("Cookie") =~ /^PART_NUMBER=RIDING_ROCKET_0023;\sPART_NUMBER=ROCKET_LAUNCHER_0001/ ); undef($c); #------------------------------------------------------------------- # When there are no "Set-Cookie" header, then even responses # without any request URLs connected should be allowed. $c = HTTP::CookieJar::LWP->new; $c->extract_cookies( HTTP::Response->new( "200", "OK" ) ); is( count_cookies($c), 0 ); #------------------------------------------------------------------- # Then we test with the examples from RFC 2965. # # 5. EXAMPLES # XXX BUT CONVERT THEM FROM COOKIE2 TO REGULAR COOKIE --xdg $c = HTTP::CookieJar::LWP->new; # # 5.1 Example 1 # # Most detail of request and response headers has been omitted. Assume # the user agent has no stored cookies. # # 1. User Agent -> Server # # POST /acme/login HTTP/1.1 # [form data] # # User identifies self via a form. # # 2. Server -> User Agent # # HTTP/1.1 200 OK # Set-Cookie2: Customer="WILE_E_COYOTE"; Version="1"; Path="/acme" # # Cookie reflects user's identity. $cookie = interact( $c, 'http://www.acme.com/acme/login', 'Customer=WILE_E_COYOTE; Path=/acme' ); ok( !$cookie ); # # 3. User Agent -> Server # # POST /acme/pickitem HTTP/1.1 # Cookie: $Version="1"; Customer="WILE_E_COYOTE"; $Path="/acme" # [form data] # # User selects an item for ``shopping basket.'' # # 4. Server -> User Agent # # HTTP/1.1 200 OK # Set-Cookie2: Part_Number="Rocket_Launcher_0001"; Version="1"; # Path="/acme" # # Shopping basket contains an item. $cookie = interact( $c, 'http://www.acme.com/acme/pickitem', 'Part_Number=Rocket_Launcher_0001; Path=/acme' ); is( $cookie, "Customer=WILE_E_COYOTE" ); # # 5. User Agent -> Server # # POST /acme/shipping HTTP/1.1 # Cookie: $Version="1"; # Customer="WILE_E_COYOTE"; $Path="/acme"; # Part_Number="Rocket_Launcher_0001"; $Path="/acme" # [form data] # # User selects shipping method from form. # # 6. Server -> User Agent # # HTTP/1.1 200 OK # Set-Cookie2: Shipping="FedEx"; Version="1"; Path="/acme" # # New cookie reflects shipping method. $cookie = interact( $c, "http://www.acme.com/acme/shipping", 'Shipping=FedEx; Path=/acme' ); like( $cookie, qr/Part_Number=Rocket_Launcher_0001/ ); like( $cookie, qr/Customer=WILE_E_COYOTE/ ); # # 7. User Agent -> Server # # POST /acme/process HTTP/1.1 # Cookie: $Version="1"; # Customer="WILE_E_COYOTE"; $Path="/acme"; # Part_Number="Rocket_Launcher_0001"; $Path="/acme"; # Shipping="FedEx"; $Path="/acme" # [form data] # # User chooses to process order. # # 8. Server -> User Agent # # HTTP/1.1 200 OK # # Transaction is complete. $cookie = interact( $c, "http://www.acme.com/acme/process" ); like( $cookie, qr/Shipping=FedEx/ ); like( $cookie, qr/WILE_E_COYOTE/ ); # # The user agent makes a series of requests on the origin server, after # each of which it receives a new cookie. All the cookies have the same # Path attribute and (default) domain. Because the request URLs all have # /acme as a prefix, and that matches the Path attribute, each request # contains all the cookies received so far. ##; # 5.2 Example 2 # # This example illustrates the effect of the Path attribute. All detail # of request and response headers has been omitted. Assume the user agent # has no stored cookies. $c = HTTP::CookieJar::LWP->new; # Imagine the user agent has received, in response to earlier requests, # the response headers # # Set-Cookie2: Part_Number="Rocket_Launcher_0001"; Version="1"; # Path="/acme" # # and # # Set-Cookie2: Part_Number="Riding_Rocket_0023"; Version="1"; # Path="/acme/ammo" interact( $c, "http://www.acme.com/acme/ammo/specific", 'Part_Number=Rocket_Launcher_0001; Path=/acme', 'Part_Number=Riding_Rocket_0023; Path=/acme/ammo' ); # A subsequent request by the user agent to the (same) server for URLs of # the form /acme/ammo/... would include the following request header: # # Cookie: $Version="1"; # Part_Number="Riding_Rocket_0023"; $Path="/acme/ammo"; # Part_Number="Rocket_Launcher_0001"; $Path="/acme" # # Note that the NAME=VALUE pair for the cookie with the more specific Path # attribute, /acme/ammo, comes before the one with the less specific Path # attribute, /acme. Further note that the same cookie name appears more # than once. $cookie = interact( $c, "http://www.acme.com/acme/ammo/..." ); like( $cookie, qr/Riding_Rocket_0023.Rocket_Launcher_0001/ ); # A subsequent request by the user agent to the (same) server for a URL of # the form /acme/parts/ would include the following request header: # # Cookie: $Version="1"; Part_Number="Rocket_Launcher_0001"; $Path="/acme" # # Here, the second cookie's Path attribute /acme/ammo is not a prefix of # the request URL, /acme/parts/, so the cookie does not get forwarded to # the server. $cookie = interact( $c, "http://www.acme.com/acme/parts/" ); ok( $cookie =~ /Rocket_Launcher_0001/ ); ok( $cookie !~ /Riding_Rocket_0023/ ); ##; #----------------------------------------------------------------------- # Test rejection of Set-Cookie2 responses based on domain, path or port $c = HTTP::CookieJar::LWP->new; # XXX RFC 6265 says strip leading dots and embedded dots in prefix are OK ### illegal domain (no embedded dots) ##$cookie = interact($c, "http://www.acme.com", 'foo=bar; domain=.com'); ##is(count_cookies($c), 0); # legal domain $cookie = interact( $c, "http://www.acme.com", 'foo=bar; domain=acme.com' ); is( count_cookies($c), 1 ); # illegal domain (host prefix "www.a" contains a dot) $cookie = interact( $c, "http://www.a.acme.com", 'foo=bar; domain=acme.com' ); is( count_cookies($c), 1 ); # legal domain $cookie = interact( $c, "http://www.a.acme.com", 'foo=bar; domain=.a.acme.com' ); is( count_cookies($c), 2 ); # can't use a IP-address as domain $cookie = interact( $c, "http://125.125.125.125", 'foo=bar; domain=125.125.125' ); is( count_cookies($c), 2 ); # XXX RFC 6265 doesn't prohibit this; path matching happens on cookie header generation ### illegal path (must be prefix of request path) ##$cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=.sol.no; path=/foo'); ##is(count_cookies($c), 2); # legal path $cookie = interact( $c, "http://www.sol.no/foo/bar", 'foo=bar; domain=.sol.no; path=/foo' ); is( count_cookies($c), 3 ); # XXX ports not part of RFC 6265 standard ### illegal port (request-port not in list) ##$cookie = interact($c, "http://www.sol.no", 'foo=bar; domain=.sol.no; port=90,100'); ##is(count_cookies($c), 3); # legal port $cookie = interact( $c, "http://www.sol.no", 'foo=bar; domain=.sol.no; port=90,100, 80,8080; max-age=100; Comment = "Just kidding! (\"\|\\\\) "' ); is( count_cookies($c), 4 ); # port attribute without any value (current port) $cookie = interact( $c, "http://www.sol.no", 'foo9=bar; domain=.sol.no; port; max-age=100;' ); is( count_cookies($c), 5 ) or diag explain $c; # encoded path $cookie = interact( $c, "http://www.sol.no/foo/", 'foo8=bar; path=/%66oo' ); is( count_cookies($c), 6 ); # XXX not doing save/load ##my $file = "lwp-cookies-$$.txt"; ##$c->save($file); ##$old = $c->as_string; ##undef($c); ##$c = HTTP::CookieJar::LWP->new; ##$c->load($file); ##unlink($file) \|\| warn "Can't unlink $file: $!"; ## ##is($old, $c->as_string); ## ##undef($c); # # Try some URL encodings of the PATHs # $c = HTTP::CookieJar::LWP->new; interact( $c, "http://www.acme.com/foo%2f%25/%40%40%0Anew%E5/%E5", 'foo = bar' ); ##; $cookie = interact( $c, "http://www.acme.com/foo%2f%25/@@%0anewå/æøå", "bar=baz; path=/foo/" ); ok( $cookie =~ /foo=bar/ ); $cookie = interact( $c, "http://www.acme.com/foo/%25/@@%0anewå/æøå" ); ok($cookie); undef($c); # ### Try to use the Netscape cookie file format for saving ### ##$file = "cookies-$$.txt"; ##$c = HTTP::CookieJar::LWP->new(file => $file); ##interact($c, "http://www.acme.com/", "foo1=bar; max-age=100"); ##interact($c, "http://www.acme.com/", "foo2=bar; port=\"80\"; max-age=100; Discard; Version=1"); ##interact($c, "http://www.acme.com/", "foo3=bar; secure; Version=1"); ##$c->save; ##undef($c); ## ##$c = HTTP::CookieJar::LWP->new(file => $file); ##is(count_cookies($c), 1); # 2 of them discarded on save ## ##ok($c->as_string =~ /foo1=bar/); ##undef($c); ##unlink($file); # # Some additional Netscape cookies test # $c = HTTP::CookieJar::LWP->new; $req = HTTP::Request->new( POST => "http://foo.bar.acme.com/foo" ); # Netscape allows a host part that contains dots $res = HTTP::Response->new( 200, "OK" ); $res->header( set_cookie => 'Customer=WILE_E_COYOTE; domain=.acme.com' ); $res->request($req); $c->extract_cookies($res); # and that the domain is the same as the host without adding a leading # dot to the domain. Should not quote even if strange chars are used # in the cookie value. $res = HTTP::Response->new( 200, "OK" ); $res->header( set_cookie => 'PART_NUMBER=3,4; domain=foo.bar.acme.com' ); $res->request($req); $c->extract_cookies($res); ##; require URI; $req = HTTP::Request->new( POST => URI->new("http://foo.bar.acme.com/foo") ); $c->add_cookie_header($req); #; ok( $req->header("Cookie") =~ /PART_NUMBER=3,4/ ); ok( $req->header("Cookie") =~ /Customer=WILE_E_COYOTE/ ); # XXX the .local mechanism is not in RFC 6265 # Test handling of local intranet hostnames without a dot ##$c->clear; ##print "---\n"; ## ##interact($c, "http://example/", "foo1=bar; PORT; Discard;"); ##$cookie=interact($c, "http://example/", 'foo2=bar; domain=".local"'); ##like($cookie, qr/foo1=bar/); ## ##$cookie=interact($c, "http://example/", 'foo3=bar'); ##$cookie=interact($c, "http://example/"); ##like($cookie, qr/foo2=bar/); ##is(count_cookies($c), 3); # Test for empty path # Broken web-server ORION/1.3.38 returns to the client response like # # Set-Cookie: JSESSIONID=ABCDERANDOM123; Path= # # e.g. with Path set to nothing. # In this case routine extract_cookies() must set cookie to / (root) $c = HTTP::CookieJar::LWP->new; # clear it $req = HTTP::Request->new( GET => "http://www.ants.com/" ); $res = HTTP::Response->new( 200, "OK" ); $res->request($req); $res->header( "Set-Cookie" => "JSESSIONID=ABCDERANDOM123; Path=" ); $c->extract_cookies($res); $req = HTTP::Request->new( GET => "http://www.ants.com/" ); $c->add_cookie_header($req); is( $req->header("Cookie"), "JSESSIONID=ABCDERANDOM123" ); # missing path in the request URI $req = HTTP::Request->new( GET => URI->new("http://www.ants.com:8080") ); $c->add_cookie_header($req); is( $req->header("Cookie"), "JSESSIONID=ABCDERANDOM123" ); # XXX we don't support Cookie2 ### test mixing of Set-Cookie and Set-Cookie2 headers. ### Example from http://www.trip.com/trs/trip/flighttracker/flight_tracker_home.xsl ### which gives up these headers: ### ### HTTP/1.1 200 OK ### Connection: close ### Date: Fri, 20 Jul 2001 19:54:58 GMT ### Server: Apache/1.3.19 (Unix) ApacheJServ/1.1.2 ### Content-Type: text/html ### Content-Type: text/html; charset=iso-8859-1 ### Link: </trip/stylesheet.css>; rel="stylesheet"; type="text/css" ### Servlet-Engine: Tomcat Web Server/3.2.1 (JSP 1.1; Servlet 2.2; Java 1.3.0; SunOS 5.8 sparc; java.vendor=Sun Microsystems Inc.) ### Set-Cookie: trip.appServer=1111-0000-x-024;Domain=.trip.com;Path=/ ### Set-Cookie: JSESSIONID=fkumjm7nt1.JS24;Path=/trs ### Set-Cookie2: JSESSIONID=fkumjm7nt1.JS24;Version=1;Discard;Path="/trs" ### Title: TRIP.com Travel - FlightTRACKER ### X-Meta-Description: Trip.com privacy policy ### X-Meta-Keywords: privacy policy ## ##$req = HTTP::Request->new('GET', 'http://www.trip.com/trs/trip/flighttracker/flight_tracker_home.xsl'); ##$res = HTTP::Response->new(200, "OK"); ##$res->request($req); ##$res->push_header("Set-Cookie" => qq(trip.appServer=1111-0000-x-024;Domain=.trip.com;Path=/)); ##$res->push_header("Set-Cookie" => qq(JSESSIONID=fkumjm7nt1.JS24;Path=/trs)); ##$res->push_header("Set-Cookie2" => qq(JSESSIONID=fkumjm7nt1.JS24;Version=1;Discard;Path="/trs")); ###; ## ##$c = HTTP::CookieJar::LWP->new; # clear it ##$c->extract_cookies($res); ##; ##is($c->as_string, <<'EOT'); ##Set-Cookie3: trip.appServer=1111-0000-x-024; path="/"; domain=.trip.com; path_spec; discard; version=0 ##Set-Cookie3: JSESSIONID=fkumjm7nt1.JS24; path="/trs"; domain=www.trip.com; path_spec; discard; version=1 ##EOT # XXX not implemented yet -- xdg, 2013-02-11 ###------------------------------------------------------------------- ### Test if temporary cookies are deleted properly with ### $jar->clear_temporary_cookies() ## ##$req = HTTP::Request->new('GET', 'http://www.perlmeister.com/scripts'); ##$res = HTTP::Response->new(200, "OK"); ##$res->request($req); ## # Set session/perm cookies and mark their values as "session" vs. "perm" ## # to recognize them later ##$res->push_header("Set-Cookie" => qq(s1=session;Path=/scripts)); ##$res->push_header("Set-Cookie" => qq(p1=perm; Domain=.perlmeister.com;Path=/;expires=Fri, 02-Feb-$year_plus_one 23:24:20 GMT)); ##$res->push_header("Set-Cookie" => qq(p2=perm;Path=/;expires=Fri, 02-Feb-$year_plus_one 23:24:20 GMT)); ##$res->push_header("Set-Cookie" => qq(s2=session;Path=/scripts;Domain=.perlmeister.com)); ##$res->push_header("Set-Cookie2" => qq(s3=session;Version=1;Discard;Path="/")); ## ##$c = HTTP::CookieJar::LWP->new; # clear jar ##$c->extract_cookies($res); ### How many session/permanent cookies do we have? ##my %counter = ("session_after" => 0); ##$c->scan( sub { $counter{"${_[2]}_before"}++ } ); ##$c->clear_temporary_cookies(); ### How many now? ##$c->scan( sub { $counter{"${_[2]}_after"}++ } ); ##is($counter{"perm_after"}, $counter{"perm_before"}); # a permanent cookie got lost accidently ##is($counter{"session_after"}, 0); # a session cookie hasn't been cleared ##is($counter{"session_before"}, 3); # we didn't have session cookies in the first place ###; # Test handling of 'secure ' attribute for classic cookies $c = HTTP::CookieJar::LWP->new; $req = HTTP::Request->new( GET => "https://1.1.1.1/" ); $req->header( "Host", "www.acme.com:80" ); $res = HTTP::Response->new( 200, "OK" ); $res->request($req); $res->header( "Set-Cookie" => "CUSTOMER=WILE_E_COYOTE ; secure ; path=/" ); #; $c->extract_cookies($res); $req = HTTP::Request->new( GET => "http://www.acme.com/" ); $c->add_cookie_header($req); ok( !$req->header("Cookie") ); $req->uri->scheme("https"); $c->add_cookie_header($req); is( $req->header("Cookie"), "CUSTOMER=WILE_E_COYOTE" ); $req = HTTP::Request->new( GET => "ftp://ftp.activestate.com/" ); $c->add_cookie_header($req); ok( !$req->header("Cookie") ); $req = HTTP::Request->new( GET => "file:/etc/motd" ); $c->add_cookie_header($req); ok( !$req->header("Cookie") ); $req = HTTP::Request->new( GET => "mailto:gisle\@aas.no" ); $c->add_cookie_header($req); ok( !$req->header("Cookie") ); # Test cookie called 'expires' <https://rt.cpan.org/Ticket/Display.html?id=8108> $c = HTTP::CookieJar::LWP->new; $cookie = interact( $c, "http://example.com/", 'Expires=10101' ); $cookie = interact( $c, "http://example.com/" ); is( $cookie, 'Expires=10101' ) or diag explain $c; # Test empty cookie header [RT#29401] $c = HTTP::CookieJar::LWP->new; $cookie = interact( $c, "http://example.com/", "CUSTOMER=WILE_E_COYOTE; path=/;", "" ); is( count_cookies($c), 1, "empty cookie not set" ); # Test empty cookie part [RT#38480] $c = HTTP::CookieJar::LWP->new; $cookie = interact( $c, "http://example.com/", "CUSTOMER=WILE_E_COYOTE;;path=/;" ); $cookie = interact( $c, "http://example.com/" ); like( $cookie, qr/CUSTOMER=WILE_E_COYOTE/, "empty attribute ignored" ); # Test Set-Cookie with version set $c = HTTP::CookieJar::LWP->new; $cookie = interact( $c, "http://example.com/", "foo=\"bar\";version=1" ); $cookie = interact( $c, "http://example.com/" ); is( $cookie, "foo=\"bar\"", "version ignored" ); # Test cookies that expire far into the future [RT#50147] ( or past ? ) # if we can't do far future, use 2037 my $future = eval { timegm( 1, 2, 3, 4, 5, 2039 ) } ? 2211 : 2037; $c = HTTP::CookieJar::LWP->new; interact( $c, "http://example.com/foo", "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL; expires=Mon, 03-Oct-$future 15:18:10 GMT; path=/; domain=.example.com", "expired1=1; expires=Mon, 03-Oct-2001 15:18:10 GMT; path=/; domain=.example.com", "expired2=1; expires=Fri Jan 1 00:00:00 GMT 1970; path=/; domain=.example.com", "expired3=1; expires=Fri Jan 1 00:00:01 GMT 1970; path=/; domain=.example.com", "expired4=1; expires=Thu Dec 31 23:59:59 GMT 1969; path=/; domain=.example.com", "expired5=1; expires=Fri Feb 2 00:00:00 GMT 1950; path=/; domain=.example.com", ); $cookie = interact( $c, "http://example.com/foo" ); is( $cookie, "PREF=ID=cee18f7c4e977184:TM=1254583090:LM=1254583090:S=Pdb0-hy9PxrNj4LL", "far future and past" ) or diag explain $c; # Test merging of cookies $c = HTTP::CookieJar::LWP->new; interact( $c, "http://example.com/foo/bar", "foo=1" ); interact( $c, "http://example.com/foo", "foo=2; path=/" ); $cookie = interact( $c, "http://example.com/foo/bar" ); is( $cookie, "foo=1; foo=2", "merging cookies" ); #------------------------------------------------------------------- sub interact { my $c = shift; my $url = shift; my $req = HTTP::Request->new( POST => $url ); $c->add_cookie_header($req); my $cookie = $req->header("Cookie"); my $res = HTTP::Response->new( 200, "OK" ); $res->request($req); for (@_) { $res->push_header( "Set-Cookie" => $_ ) } $c->extract_cookies($res); return $cookie; } sub count_cookies { my $c = shift; return scalar $c->_all_cookies; } done_testing; # # This file is part of HTTP-CookieJar # # This software is Copyright (c) 2013 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��cookies_for.t��0000644��00000002417�15125143560�0007241 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use Test::Deep '!blessed'; use lib 't/lib'; use MockTime; use HTTP::CookieJar; my $url = "http://example.com/foo/bar/"; my @input = ( [ $url, "SID=2; Path=/" ], [ $url, "SID=1; Path=/foo" ], [ $url, "SID=0; Path=/foo/bar" ], ); # MockTime keeps this constant my $creation_time = time; my $jar = HTTP::CookieJar->new; $jar->add(@$_) for @input; # Move up the clock for access time MockTime->offset(10); my $last_access_time = time; # Check that cookies_for has expected times for my $c ( $jar->cookies_for($url) ) { is( $c->{creation_time}, $creation_time, "$c->{name}=$c->{value} creation_time" ); is( $c->{last_access_time}, $last_access_time, "$c->{name}=$c->{value} last_access_time" ); } # Modify cookies from cookies_for and verify they aren't changed # from private originals. for my $c ( $jar->cookies_for($url) ) { $c->{creation_time} = 0; } for my $c ( $jar->_cookies_for($url) ) { is( $c->{creation_time}, $creation_time, "$c->{name}=$c->{value} creation_time" ); } done_testing; # # This file is part of HTTP-CookieJar # # This software is Copyright (c) 2013 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��publicsuffix.t��0000644��00000006036�15125143560�0007443 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use Test::Deep '!blessed'; use Test::Requires 'Mozilla::PublicSuffix'; use HTTP::CookieJar; my @cases = ( { label => "host is public suffix", request => "http://com.au/", cookies => ["SID=31d4d96e407aad42; Domain=com.au"], store => { 'com.au' => { '/' => { SID => { name => "SID", value => "31d4d96e407aad42", creation_time => ignore(), last_access_time => ignore(), domain => "com.au", hostonly => 1, path => "/", } } }, }, }, { label => "host is suffix of public suffix", request => "http://au/", cookies => ["SID=31d4d96e407aad42; Domain=au"], store => { 'au' => { '/' => { SID => { name => "SID", value => "31d4d96e407aad42", creation_time => ignore(), last_access_time => ignore(), domain => "au", hostonly => 1, path => "/", } } }, }, }, { label => "host is unrecognized single level", request => "http://localhost/", cookies => ["SID=31d4d96e407aad42; Domain=localhost"], store => { 'localhost' => { '/' => { SID => { name => "SID", value => "31d4d96e407aad42", creation_time => ignore(), last_access_time => ignore(), domain => "localhost", hostonly => 1, path => "/", } } }, }, }, { label => "cookie is public suffix", request => "http://example.com.au/", cookies => ["SID=31d4d96e407aad42; Domain=com.au"], store => {}, }, { label => "cookie is suffix of public suffix", request => "http://example.com.au/", cookies => ["SID=31d4d96e407aad42; Domain=au"], store => {}, }, ); for my $c (@cases) { my $jar = HTTP::CookieJar->new; for my $cookie ( @{ $c->{cookies} } ) { $jar->add( $c->{request}, $cookie ); } cmp_deeply $jar->{store}, $c->{store}, $c->{label} or diag explain $jar->{store}; } done_testing; # # This file is part of HTTP-CookieJar # # This software is Copyright (c) 2013 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��parse.t��0000644��00000005216�15125143560�0006051 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use Test::Deep '!blessed'; use HTTP::CookieJar; my @cases = ( { cookie => "", parse => undef, }, { cookie => "SID=", parse => { name => "SID", value => "", } }, { cookie => "=31d4d96e407aad42", parse => undef, }, { cookie => "; Max-Age: 1360343635", parse => undef, }, { cookie => "SID=31d4d96e407aad42", parse => { name => "SID", value => "31d4d96e407aad42", } }, { cookie => "SID=ID=31d4d96e407aad42", parse => { name => "SID", value => "ID=31d4d96e407aad42", } }, { cookie => "SID=31d4d96e407aad42 ; ; ; ", parse => { name => "SID", value => "31d4d96e407aad42", } }, { cookie => "SID=31d4d96e407aad42; Path=/; Secure; HttpOnly", parse => { name => "SID", value => "31d4d96e407aad42", path => "/", secure => 1, httponly => 1, } }, { cookie => "SID=31d4d96e407aad42; Domain=.example.com", parse => { name => "SID", value => "31d4d96e407aad42", domain => "example.com", } }, { cookie => "SID=31d4d96e407aad42; Path=/; Domain=example.com", parse => { name => "SID", value => "31d4d96e407aad42", path => "/", domain => "example.com", } }, { cookie => "SID=31d4d96e407aad42; Path=/; Domain=", parse => { name => "SID", value => "31d4d96e407aad42", path => "/", } }, { cookie => "lang=en-US; Expires = Sun, 09 Jun 2041 10:18:14 GMT", parse => { name => "lang", value => "en-US", expires => 2254385894, } }, { cookie => "lang=en-US; Expires = Sun, 09 Jun 2041 10:18:14 GMT; Max-Age=3600", parse => { name => "lang", value => "en-US", expires => 2254385894, 'max-age' => 3600, } }, ); for my $c (@cases) { my $got = HTTP::CookieJar::_parse_cookie( $c->{cookie} ); cmp_deeply $got, $c->{parse}, $c->{cookie} \|\| q{''}; } done_testing; # # This file is part of HTTP-CookieJar # # This software is Copyright (c) 2013 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��sort.t��0000644��00000002744�15125143560�0005731 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use Test::Deep '!blessed'; use lib 't/lib'; use MockTime; use HTTP::CookieJar; my @cases = ( { label => "path length", request => "http://example.com/foo/bar/", cookies => [ [ "http://example.com/foo/bar/", "SID=2; Path=/" ], [ "http://example.com/foo/bar/", "SID=1; Path=/foo" ], [ "http://example.com/foo/bar/", "SID=0; Path=/foo/bar" ], ], }, { label => "creation time", request => "http://foo.bar.baz.example.com/", cookies => [ [ "http://foo.bar.baz.example.com/", "SID=0; Path=/; Domain=bar.baz.example.com" ], [ "http://foo.bar.baz.example.com/", "SID=1; Path=/; Domain=baz.example.com" ], [ "http://foo.bar.baz.example.com/", "SID=2; Path=/; Domain=example.com" ], ], }, ); for my $c (@cases) { my $jar = HTTP::CookieJar->new; my $offset = 0; for my $cookie ( @{ $c->{cookies} } ) { MockTime->offset($offset); $jar->add(@$cookie); $offset += 10; } my @cookies = $jar->cookies_for( $c->{request} ); my @vals = map { $_->{value} } @cookies; cmp_deeply \@vals, [ 0 .. $#vals ], $c->{label} or diag explain \@cookies; } done_testing; # # This file is part of HTTP-CookieJar # # This software is Copyright (c) 2013 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��save.t��0000644��00000004171�15125143560�0005674 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use Test::Deep '!blessed'; use HTTP::CookieJar; my $jar = HTTP::CookieJar->new; my $jar2; my @cookies = ( 'SID=31d4d96e407aad42; Path=/; Secure; HttpOnly', ); my @persistent = ( 'lang=en_US; Path=/; Domain=example.com; Secure; HttpOnly; Max-Age = 3600', ); subtest "empty cookie jar" => sub { my $jar = HTTP::CookieJar->new; my @list = $jar->dump_cookies; is( scalar @list, 0, "dumped zero cookies" ); ok( my $jar2 = HTTP::CookieJar->new->load_cookies(@list), "load new cookie jar" ); is( scalar $jar2->dump_cookies, 0, "second jar is empty" ); }; subtest "roundtrip" => sub { my $jar = HTTP::CookieJar->new; $jar->add( "http://www.example.com/", $_ ) for @cookies, @persistent; my @list = $jar->dump_cookies; is( scalar @list, @cookies + @persistent, "dumped correct number of cookies" ); ok( my $jar2 = HTTP::CookieJar->new->load_cookies(@list), "load new cookie jar" ); is( scalar $jar2->dump_cookies, @cookies + @persistent, "second jar has correct count" ); cmp_deeply( $jar, $jar2, "old and new jars are the same" ) or diag explain [ $jar, $jar2 ]; }; subtest "persistent" => sub { my $jar = HTTP::CookieJar->new; $jar->add( "http://www.example.com/", $_ ) for @cookies, @persistent; my @list = $jar->dump_cookies( { persistent => 1 } ); is( scalar @list, @cookies, "dumped correct number of cookies" ); ok( my $jar2 = HTTP::CookieJar->new->load_cookies(@list), "load new cookie jar" ); is( scalar $jar2->dump_cookies, @cookies, "second jar has correct count" ); }; # can load raw cookies with both path and domain subtest "liberal load" => sub { my $jar = HTTP::CookieJar->new; ok( $jar->load_cookies( @persistent, @cookies ), "load_cookies with raw cookies" ); is( scalar $jar->dump_cookies, @persistent, "jar has correct count" ); }; done_testing; # # This file is part of HTTP-CookieJar # # This software is Copyright (c) 2013 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # # vim: ts=4 sts=4 sw=4 et: ��add.t��0000644��00000021162�15125143560�0005465 0��ustar�00��use 5.008001; use strict; use warnings; use Test::More 0.96; use Test::Deep '!blessed'; use HTTP::CookieJar; my @cases = ( { label => "no cookies", request => "http://example.com/", cookies => [], store => {}, }, { label => "simple key=value", request => "http://example.com/", cookies => ["SID=31d4d96e407aad42"], store => { 'example.com' => { '/' => { SID => { name => "SID", value => "31d4d96e407aad42", creation_time => ignore(), last_access_time => ignore(), domain => "example.com", hostonly => 1, path => "/", } } }, }, }, { label => "invalid cookie not stored", request => "http://example.com/", cookies => [";"], store => {}, }, { label => "localhost treated as host only", request => "http://localhost/", cookies => ["SID=31d4d96e407aad42; Domain=localhost"], store => { 'localhost' => { '/' => { SID => { name => "SID", value => "31d4d96e407aad42", creation_time => ignore(), last_access_time => ignore(), domain => "localhost", hostonly => 1, path => "/", } } }, }, }, { label => "single domain level treated as host only", request => "http://foobar/", cookies => ["SID=31d4d96e407aad42; Domain=foobar"], store => { 'foobar' => { '/' => { SID => { name => "SID", value => "31d4d96e407aad42", creation_time => ignore(), last_access_time => ignore(), domain => "foobar", hostonly => 1, path => "/", } } }, }, }, { label => "different domain not stored", request => "http://example.com/", cookies => ["SID=31d4d96e407aad42; Domain=example.org"], store => {}, }, { label => "subdomain not stored", request => "http://example.com/", cookies => ["SID=31d4d96e407aad42; Domain=www.example.com"], store => {}, }, { label => "superdomain stored", request => "http://www.example.com/", cookies => ["SID=31d4d96e407aad42; Domain=example.com"], store => { 'example.com' => { '/' => { SID => { name => "SID", value => "31d4d96e407aad42", creation_time => ignore(), last_access_time => ignore(), domain => "example.com", path => "/", } } }, }, }, { label => "path prefix /foo/ stored", request => "http://www.example.com/foo/bar", cookies => ["SID=31d4d96e407aad42; Path=/foo/"], store => { 'www.example.com' => { '/foo/' => { SID => { name => "SID", value => "31d4d96e407aad42", creation_time => ignore(), last_access_time => ignore(), domain => "www.example.com", hostonly => 1, path => "/foo/", } } }, }, }, { label => "path prefix /foo stored", request => "http://www.example.com/foo/bar", cookies => ["SID=31d4d96e407aad42; Path=/foo"], store => { 'www.example.com' => { '/foo' => { SID => { name => "SID", value => "31d4d96e407aad42", creation_time => ignore(), last_access_time => ignore(), domain => "www.example.com", hostonly => 1, path => "/foo", } } }, }, }, { label => "last cookie wins", request => "http://example.com/", cookies => [ "SID=31d4d96e407aad42", "SID=0000000000000000", ], store => { 'example.com' => { '/' => { SID => { name => "SID", value => "0000000000000000", creation_time => ignore(), last_access_time => ignore(), domain => "example.com", hostonly => 1, path => "/", } } }, }, }, { label => "expired supercedes prior", request => "http://example.com/", cookies => [ "SID=31d4d96e407aad42", "SID=0000000000000000; Max-Age=-60", ], store => { 'example.com' => { '/' => {}, }, }, }, { label => "separated by path", request => "http://example.com/foo/bar", cookies => [ "SID=31d4d96e407aad42; Path=/", "SID=0000000000000000", ], store => { 'example.com' => { '/' => { SID => { name => "SID", value => "31d4d96e407aad42", creation_time => ignore(), last_access_time => ignore(), domain => "example.com", hostonly => 1, path => "/", } }, '/foo' => { SID => { name => "SID", value => "0000000000000000", creation_time => ignore(), last_access_time => ignore(), domain => "example.com", hostonly => 1, path => "/foo", } } }, }, }, # check that Max-Age supercedes Expires and that Max-Age <= 0 forces # expiration { label => "max-age supercedes expires", request => "http://example.com/", cookies => [ "lang=en-us; Max-Age=100; Expires=Thu, 1 Jan 1970 00:00:00 GMT", "SID=0000000000000000; Expires=Thu, 3 Jan 4841 00:00:00 GMT", "SID=31d4d96e407aad42; Max-Age=0; Expires=Thu, 3 Jan 4841 00:00:00 GMT", "FOO=0000000000000000; Max-Age=-100; Expires=Thu, 3 Jan 4841 00:00:00 GMT", ], store => { 'example.com' => { '/' => { lang => { name => "lang", value => "en-us", expires => ignore(), creation_time => ignore(), last_access_time => ignore(), domain => "example.com", hostonly => 1, path => "/", }, }, }, }, }, ); for my $c (@cases) { my $jar = HTTP::CookieJar->new; for my $cookie ( @{ $c->{cookies} } ) { $jar->add( $c->{request}, $cookie ); } cmp_deeply $jar->{store}, $c->{store}, $c->{label} or diag explain $jar->{store}; } done_testing; # # This file is part of HTTP-CookieJar # # This software is Copyright (c) 2013 by David Golden. # # This is free software, licensed under: # # The Apache License, Version 2.0, January 2004 # ��lib/MockTime.pm��0000644��00000000473�15125143560�0007366 0��ustar�00��use strict; use warnings; package MockTime; my ( $_original_time, $_offset ); sub time () { return $_original_time + $_offset; } sub offset { my ( $class, $offset ) = @_; $_offset = $offset; } BEGIN { ( $_original_time, $_offset ) = ( CORE::time(), 0 ); CORE::GLOBAL::time = \&time; } 1; ��07_eval.t��0000644��00000001145�15125143577�0006201 0��ustar�00��#!perl -w use strict; use Test::More tests => 6; use Test::LeakTrace; for(1 .. 2){ leaks_cmp_ok{ eval q{ my %a = (foo => 42); my %b = (bar => 3.14); $b{a} = \%a; $a{b} = \%b; 1 } or die $@; } '>', 0; my @info = leaked_info { eval q{ my %a = (foo => 42); my %b = (bar => 3.14); $b{a} = \%a; $a{b} = \%b; 1; } or die $@; }; cmp_ok scalar(@info), '>', 0; @info = leaked_info{ use Class::Struct; # use eval() for build classes struct "Foo$_" => { bar => '$' }; my $foo = "Foo$_"->new(); $foo->bar(42); }; cmp_ok scalar(@info), '>', 0, "create Foo$_"; } ��10_bad_use.t��0000644��00000001116�15125143577�0006644 0��ustar�00��#!perl -w use strict; use Test::More tests => 6; use Test::LeakTrace; for(1 .. 2){ eval{ my @a = leaked_refs{ my @b = leaked_refs{ my %a = (foo => 42); my %b = (bar => 3.14); $b{a} = \%a; $a{b} = \%b; }; }; }; isnt $@, '', 'multi leaktrace'; eval{ leaktrace{ my %a = (foo => 42); my %b = (bar => 3.14); $b{a} = \%a; $a{b} = \%b; } sub { die ['foo']; }; }; is_deeply $@, ['foo'], 'die in callback'; eval{ leaktrace{ my @array; push @array, \@array; } -foobar; }; like $@, qr/Invalid reporting mode/, 'invalid mode'; } ��06_threads.t��0000644��00000001112�15125143577�0006675 0��ustar�00��#!perl -w use strict; use constant HAS_THREADS => eval{ require threads }; use Test::More; BEGIN{ if(HAS_THREADS){ plan tests => 6; } else{ plan skip_all => 'require threads'; } } use threads; use Test::LeakTrace; leaks_cmp_ok{ async{ my $a = 0; $a++; }->join; } '<', 10; my $count = leaked_count { async{ leaks_cmp_ok{ my @a; push @a, \@a; } '>', 0; no_leaks_ok{ my $a; $a++; }; }->join; }; cmp_ok $count, '<', 10, "(actually leaked: $count)"; async{ no_leaks_ok{ my $a = 0; $a++; }; no_leaks_ok{ my $a = 0; $a++; }; }->join(); ��04_test_funcs.t��0000644��00000001015�15125143577�0007420 0��ustar�00��#!perl -w use strict; use Test::More tests => 8; use Test::LeakTrace qw(:test); { package Foo; sub new{ return bless {}, shift; } } no_leaks_ok { my %a; my %b; $a{b} = 1; $b{a} = 2; } 'not leaked'; no_leaks_ok{ my $o = Foo->new(); $o->{bar}++; }; no_leaks_ok{ # empty }; leaks_cmp_ok{ my $a; $a++; } '==', 0; sub leaked{ my %a; my %b; $a{b} = \%b; $b{a} = \%a; } leaks_cmp_ok \&leaked, '<', 10; leaks_cmp_ok \&leaked, '<=', 10; leaks_cmp_ok \&leaked, '>', 0; leaks_cmp_ok \&leaked, '>=', 1; ��13_do.t��0000755��00000000314�15125143577�0005651 0��ustar�00��#!perl -w # related to https://rt.cpan.org/Public/Bug/Display.html?id=58133 use strict; use Test::More tests => 1; use Test::LeakTrace; sub foo{ do './t/lib/foo.pl'; } no_leaks_ok \&foo, 'do $file'; ��05_script.t��0000644��00000000317�15125143577�0006554 0��ustar�00��#!perl -w use strict; use Test::More tests => 1; BEGIN{ pass 'script interface'; } use Test::LeakTrace::Script; my $i = 0; for(1 .. 10){ my @array = (1 .. 10); my %hash = (foo => 'bar'); $i++; } ��12_padstale.t��0000644��00000000317�15125143577�0007043 0��ustar�00��#!perl -w use strict; use Test::More tests => 1; use Test::LeakTrace; sub foo{ my $foo = 42; my @array; my %hash; [\$foo, \@array, \%hash]; } no_leaks_ok \&foo, 'PADSTALE sv is not a memory leak'; ��02_refs.t��0000644��00000001005�15125143577�0006177 0��ustar�00��#!perl -w use strict; use Test::More tests => 3; use Test::LeakTrace; my $a; my @refs = leaked_refs{ $a = []; }; is_deeply \@refs, [ [] ] or do{ require Data::Dumper; diag(Data::Dumper->Dump([\@refs], ['refs'])); }; @refs = leaked_refs{ my %a = (foo => 42); my %b = (bar => 3.14); $b{a} = \%a; $a{b} = \%b; }; cmp_ok(scalar(@refs), '>=', 2) or do{ require Data::Dumper; diag(Data::Dumper->Dump([\@refs], ['refs'])); }; cmp_ok scalar(grep{ ref($_) eq 'REF' && ref(${$_}) eq 'HASH' } @refs), '>=', 2; ��03_count.t��0000644��00000000711�15125143577�0006374 0��ustar�00��#!perl -w use strict; use Test::More tests => 5; use Test::LeakTrace; sub normal{ my %a; my %b; $a{b} = 1; $b{a} = 2; } cmp_ok leaked_count(\&normal), '<=', 0, 'not leaked(1)'; cmp_ok leaked_count(\&normal), '<=', 0, 'not leaked(2)'; sub leaked{ my %a; my %b; $a{b} = \%b; $b{a} = \%a; } cmp_ok leaked_count(\&leaked), '>', 0; is leaked_count(\&leaked), scalar(leaked_info \&leaked); is leaked_count(\&leaked), scalar(leaked_refs \&leaked); ��00_compile.t��0000644��00000000222�15125143577�0006666 0��ustar�00��#!perl -w use strict; use Test::More tests => 1; BEGIN { use_ok 'Test::LeakTrace' } diag "Testing Test::LeakTrace/$Test::LeakTrace::VERSION"; ��01_info.t��0000644��00000001652�15125143577�0006202 0��ustar�00��#!perl -w use strict; use Test::More tests => 4; use Test::LeakTrace; use autouse 'Data::Dumper' => 'Dumper'; my @info = leaked_info{ my %a = (foo => 42); my %b = (bar => 3.14); $b{a} = \%a; $a{b} = \%b; pass 'in leaktrace block'; }; cmp_ok(scalar(@info), '>', 1) or diag(Dumper(\@info)); my($si) = grep { my $ref = $_->[0]; ref($ref) eq 'REF' and ref(${$ref}) eq 'HASH' and exists ${$ref}->{a} } @info; like __FILE__, qr/\Q$si->[1]\E/, 'state info' or diag(Dumper \@info); @info = leaked_info{ #line 1 here_is_extreamely_long_file_name_that_tests_the_file_name_limitation_in_stateinfo_in_LeakTrace_xs my %a = (foo => 42); my %b = (bar => 3.14); $b{a} = \%a; $a{b} = \%b; }; ($si) = grep { my $ref = $_->[0]; ref($ref) eq 'REF' and ref(${$ref}) eq 'HASH' and exists ${$ref}->{a} } @info; is 'here_is_extreamely_long_file_name_that_tests_the_file_name_limitation_in_stateinfo_in_LeakTrace_xs', $si->[1]; ��08_leaktrace.t��0000644��00000001046�15125143577�0007206 0��ustar�00��#!perl -w use strict; use Test::More 'no_plan'; # I don't know the number of 'ok' use Test::LeakTrace; ok defined &leaktrace; leaktrace{ my %a = (foo => 42); my %b = (bar => 3.14); $b{a} = \%a; $a{b} = \%b; pass 'in leaktrace block'; } sub { my($ref, $file, $line) = @_; is scalar(@_), 3, 'leaktrace callback args is 3 (svref, file, line)'; ok ref($ref), ref $ref; isnt ref($ref), 'UNKNOWN'; isnt $file, undef; isnt $line, undef; }; leaktrace{ my %a = (foo => 42); my %b = (bar => 3.14); } sub { fail 'must not be called'; }; ��lib/foo.pl��0000755��00000000002�15125143577�0006437 0��ustar�00��1;��11_logfp.t��0000644��00000002043�15125143577�0006352 0��ustar�00��#!perl -w use strict; use Test::More tests => 16; use Test::LeakTrace qw(:util); my $content = ''; sub t{ open local(STDERR), '>', \$content; leaktrace{ my @array; push @array, 42, \@array; } shift; } $\ = 'rs'; $_ = 'defsv'; my $file = __FILE__; t(-simple); like $content, qr/from \Q$file\E line 15\./, -simple; unlike $content, qr/15:\t\tpush \@array/, -lines; unlike $content, qr/REFCNT/, -sv_dump; t(-lines); like $content, qr/from \Q$file\E line 15\./, -simple; like $content, qr/15:\t\tpush \@array/, -lines; unlike $content, qr/REFCNT/, -sv_dump; t(-sv_dump); like $content, qr/from \Q$file\E line 15\./, -simple; unlike $content, qr/15:\t\tpush \@array/, -lines; like $content, qr/REFCNT/, -sv_dump; t(-verbose); like $content, qr/from \Q$file\E line 15\./, -simple; like $content, qr/15:\t\tpush \@array/, -lines; like $content, qr/REFCNT/, -sv_dump; t(-silent); is $content, '', -silent; eval{ t(sub{ die }); }; is $content, '', 'died in callback'; is $\, 'rs', '$\ is not affected'; is $_, 'defsv', '$_ is not affected'; ��09_info_more.t��0000644��00000001422�15125143577�0007227 0��ustar�00��#!perl -w use strict; use Test::More tests => 7; use Test::LeakTrace qw(:all); use autouse 'Data::Dumper' => 'Dumper'; my @info = leaked_info{ my %a = (foo => 42); my %b; $b{bar} = 3.14; { $b{a} = \%a; } $a{b} = \%b; }; cmp_ok(scalar(@info), '>', 2) or diag(Dumper \@info); is_deeply [grep{ eq_array [$_->[0]], [\42] } @info], [ [\42, __FILE__, 10] ]; is_deeply [grep{ eq_array [$_->[0]], [\3.14] } @info], [ [\3.14, __FILE__, 13] ]; my(@x) = grep{ my $r = $_->[0]; ref($r) eq 'REF' && ref(${$r}) eq 'HASH' && exists ${$r}->{b} } @info; is scalar(@x), 1 or diag(Dumper \@x); is $x[0][2], 16; # line (@x) = grep{ my $r = $_->[0]; ref($r) eq 'REF' && ref(${$r}) eq 'HASH' && exists ${$r}->{a} } @info; is scalar(@x), 1 or diag(Dumper \@x); is $x[0][2], 18; # line ��roytest3.html��0000644��00000006017�15125162450�0007233 0��ustar�00��<HTML><HEAD> <TITLE>Examples of Resolving Relative URLs, Part 3</TITLE> <BASE href="http://a/b/c/d;p=1/2?q"> </HEAD><BODY> <H1>Examples of Resolving Relative URLs, Part 3</H1> This document has an embedded base URL of <PRE> Content-Base: http://a/b/c/d;p=1/2?q </PRE> the relative URLs should be resolved as shown below. For this test page, I am particularly interested in testing whether "/" in parameters is or is not treated as part of the path hierarchy. <P> I will need your help testing the examples on multiple browsers. What you need to do is point to the example anchor and compare it to the resolved URL in your browser (most browsers have a feature by which you can see the resolved URL at the bottom of the window/screen when the anchor is active). <H2>Tested Clients and Client Libraries</H2> <DL COMPACT> <DT>[R] <DD>RFC 2396 (the right way to parse) <DT>[X] <DD>RFC 1808 <DT>[1] <DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav) <DT>[2] <DD>Lynx/2.7.1 libwww-FM/2.14 <DT>[3] <DD>MSIE 3.01; Windows 95 <DT>[4] <DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) libwww/2.12 </DL> <H3>Synopsis</H3> RFC 1808 specified that the "/" character within parameter information does not affect the hierarchy within URL parsing. It would appear that it does in current practice. This implies that the parameters should be part of each path segment and not outside the path. The URI draft has been written accordingly. <H2>Examples</H2> <PRE> RESULTS from <a href="g">g</a> = http://a/b/c/d;p=1/g [R,1,2,3,4] http://a/b/c/g [X] <a href="./g">./g</a> = http://a/b/c/d;p=1/g [R,1,2,3,4] http://a/b/c/g [X] <a href="g/">g/</a> = http://a/b/c/d;p=1/g/ [R,1,2,3,4] http://a/b/c/g/ [X] <a href="g?y">g?y</a> = http://a/b/c/d;p=1/g?y [R,1,2,3,4] http://a/b/c/g?y [X] <a href=";x">;x</a> = http://a/b/c/d;p=1/;x [R,1,2,3,4] http://a/b/c/d;x [X] <a href="g;x">g;x</a> = http://a/b/c/d;p=1/g;x [R,1,2,3,4] http://a/b/c/g;x [X] <a href="g;x=1/./y">g;x=1/./y</a> = http://a/b/c/d;p=1/g;x=1/y [R,1,2,3,4] http://a/b/c/g;x=1/./y [X] <a href="g;x=1/../y">g;x=1/../y</a> = http://a/b/c/d;p=1/y [R,1,2,3,4] http://a/b/c/g;x=1/../y [X] <a href="./">./</a> = http://a/b/c/d;p=1/ [R,1,2,3,4] http://a/b/c/ [X] <a href="../">../</a> = http://a/b/c/ [R,1,2,3,4] http://a/b/ [X] <a href="../g">../g</a> = http://a/b/c/g [R,1,2,3,4] http://a/b/g [X] <a href="../../">../../</a> = http://a/b/ [R,1,2,3,4] http://a/ [X] <a href="../../g">../../g</a> = http://a/b/g [R,1,2,3,4] http://a/g [X] </PRE> </BODY></HTML> ��query.t��0000644��00000006455�15125162450�0006111 0��ustar�00��use strict; use warnings; use Test::More tests => 37; use URI (); my $u = URI->new("", "http"); my @q; # For tests using array object { package Foo::Bar::Array; sub new { my $this = shift( @_ ); return( bless( ( @_ == 1 && ref( $_[0] \|\| '' ) eq 'ARRAY' ) ? shift( @_ ) : [@_] => ( ref( $this ) \|\| $this ) ) ); } package Foo::Bar::Stringy; push( @Foo::Bar::Stringy::ISA, 'Foo::Bar::Array' ); use overload ( '""' => '_as_string', ); sub _as_string { my $self = shift; local $" = '_hello_'; return( "@$self" ); } } $u->query_form(a => 3, b => 4); is $u, "?a=3&b=4"; $u->query_form(a => undef); is $u, "?a"; $u->query_form("a[=&+#] " => " [=&+#]"); is $u, "?a%5B%3D%26%2B%23%5D+=+%5B%3D%26%2B%23%5D"; @q = $u->query_form; is join(":", @q), "a[=&+#] : [=&+#]"; @q = $u->query_keywords; ok !@q; $u->query_keywords("a", "b"); is $u, "?a+b"; $u->query_keywords(" ", "+", "=", "[", "]"); is $u, "?%20+%2B+%3D+%5B+%5D"; @q = $u->query_keywords; is join(":", @q), " :+:=:[:]"; @q = $u->query_form; ok !@q; $u->query(" +?=#"); is $u, "?%20+?=%23"; $u->query_keywords([qw(a b)]); is $u, "?a+b"; # Same, but using array object $u->query_keywords(Foo::Bar::Array->new([qw(a b)])); is $u, "?a+b"; # Same, but using a stringifyable array object $u->query_keywords(Foo::Bar::Stringy->new([qw(a b)])); is $u, "?a_hello_b"; $u->query_keywords([]); is $u, ""; # Same, but using array object $u->query_keywords(Foo::Bar::Array->new([])); is $u, ""; # Same, but using a stringifyable array object $u->query_keywords(Foo::Bar::Stringy->new([])); is $u, "?"; $u->query_form({ a => 1, b => 2 }); ok $u eq "?a=1&b=2" \|\| $u eq "?b=2&a=1"; $u->query_form([ a => 1, b => 2 ]); is $u, "?a=1&b=2"; # Same, but using array object $u->query_form(Foo::Bar::Array->new([ a => 1, b => 2 ])); is $u, "?a=1&b=2"; $u->query_form({}); is $u, ""; $u->query_form([a => [1..4]]); is $u, "?a=1&a=2&a=3&a=4"; # Same, but using array object $u->query_form(Foo::Bar::Array->new([a => [1..4]])); is $u, "?a=1&a=2&a=3&a=4"; $u->query_form([]); is $u, ""; # Same, but using array object $u->query_form(Foo::Bar::Array->new([])); is $u, ""; # Same, but using a strngifyable array object $u->query_form(Foo::Bar::Stringy->new([])); is $u, ""; $u->query_form(a => { foo => 1 }); ok "$u" =~ /^\?a=HASH\(/; $u->query_form(a => 1, b => 2, ';'); is $u, "?a=1;b=2"; $u->query_form(a => 1, c => 2); is $u, "?a=1;c=2"; $u->query_form(a => 1, c => 2, '&'); is $u, "?a=1&c=2"; $u->query_form([a => 1, b => 2], ';'); is $u, "?a=1;b=2"; # Same, but using array object $u->query_form(Foo::Bar::Array->new([a => 1, b => 2]), ';'); is $u, "?a=1;b=2"; # Same, but using a stringifyable array object $u->query_form("c" => Foo::Bar::Stringy->new([a => 1, b => 2]), "d" => "e", ';'); is $u, "?c=a_hello_1_hello_b_hello_2;d=e"; $u->query_form([]); { local $URI::DEFAULT_QUERY_FORM_DELIMITER = ';'; $u->query_form(a => 1, b => 2); } is $u, "?a=1;b=2"; # Same, but using array object $u->query_form(Foo::Bar::Array->new([])); { local $URI::DEFAULT_QUERY_FORM_DELIMITER = ';'; $u->query_form(a => 1, b => 2); } is $u, "?a=1;b=2"; $u->query('a&b=2'); @q = $u->query_form; is join(":", map { defined($_) ? $_ : '' } @q), "a::b:2"; ok !defined($q[1]); $u->query_form(@q); is $u,'?a&b=2'; ��iri.t��0000644��00000005322�15125162450�0005517 0��ustar�00��use strict; use warnings; use utf8; use Test::More; use Config qw( %Config ); if (defined $Config{useperlio}) { plan tests=>30; } else { plan skip_all=>"this perl doesn't support PerlIO layers"; } use URI (); use URI::IRI (); my $u; binmode Test::More->builder->output, ':encoding(UTF-8)'; binmode Test::More->builder->failure_output, ':encoding(UTF-8)'; $u = URI->new("http://Bücher.ch"); is $u, "http://xn--bcher-kva.ch"; is $u->host, "xn--bcher-kva.ch"; is $u->ihost, "bücher.ch"; is $u->as_iri, "http://bücher.ch"; # example from the docs for host and ihost $u = URI->new("http://www.\xC3\xBCri-sample/foo/bar.html"); is $u, "http://www.xn--ri-sample-fra0f/foo/bar.html"; is $u->host, "www.xn--ri-sample-fra0f"; is $u->ihost, "www.\xC3\xBCri-sample"; is $u->as_iri, "http://www.\xC3\xBCri-sample/foo/bar.html"; $u = URI->new("http://example.com/Bücher"); is $u, "http://example.com/B%C3%BCcher"; is $u->as_iri, "http://example.com/Bücher"; $u = URI->new("http://example.com/B%FCcher"); # latin1 encoded stuff is $u->as_iri, "http://example.com/B%FCcher"; # ...should not be decoded $u = URI->new("http://example.com/B\xFCcher"); is $u->as_string, "http://example.com/B%FCcher"; is $u->as_iri, "http://example.com/B%FCcher"; $u = URI::IRI->new("http://example.com/B\xFCcher"); is $u->as_string, "http://example.com/Bücher"; is $u->as_iri, "http://example.com/Bücher"; # draft-duerst-iri-bis.txt claims this should map to xn--rsum-bad.example.org $u = URI->new("http://r\xE9sum\xE9.example.org"); is $u->as_string, "http://xn--rsum-bpad.example.org"; $u = URI->new("http://xn--rsum-bad.example.org"); is $u->as_iri, "http://r\x80sum\x80.example.org"; $u = URI->new("http://r%C3%A9sum%C3%A9.example.org"); is $u->as_string, "http://r%C3%A9sum%C3%A9.example.org"; is $u->as_iri, "http://r\xE9sum\xE9.example.org"; $u = URI->new("http://➡.ws/"); is $u, "http://xn--hgi.ws/"; is $u->host, "xn--hgi.ws"; is $u->ihost, "➡.ws"; is $u->as_iri, "http://➡.ws/"; # draft-duerst-iri-bis.txt examples (section 3.7.1): is(URI->new("http://www.example.org/D%C3%BCrst")->as_iri, "http://www.example.org/D\xFCrst"); is(URI->new("http://www.example.org/D%FCrst")->as_iri, "http://www.example.org/D%FCrst"); TODO: { local $TODO = "some chars (like U+202E, RIGHT-TO-LEFT OVERRIDE) need to stay escaped"; is(URI->new("http://xn--99zt52a.example.org/%e2%80%ae")->as_iri, "http://\x{7D0D}\x{8C46}.example.org/%e2%80%ae"); } # try some URLs that can't be IDNA encoded (fallback to encoded UTF8 bytes) $u = URI->new("http://" . ("ü" x 128)); is $u, "http://" . ("%C3%BC" x 128); is $u->host, ("\xC3\xBC" x 128); TODO: { local $TODO = "should ihost decode UTF8 bytes?"; is $u->ihost, ("ü" x 128); } is $u->as_iri, "http://" . ("ü" x 128); ��num_eq.t��0000644��00000000605�15125162450�0006217 0��ustar�00��# Test URI's overloading of numeric comparison for checking object # equality use strict; use warnings; use Test::More 'no_plan'; use URI (); my $uri1 = URI->new("http://foo.com"); my $uri2 = URI->new("http://foo.com"); # cmp_ok() has a bug/misfeature where it strips overloading # before doing the comparison. So use a regular ok(). ok $uri1 == $uri1, "=="; ok $uri1 != $uri2, "!="; ��geo_construct.t��0000644��00000004150�15125162450�0007610 0��ustar�00��#!perl use strict; use warnings; use URI::geo; use Test::More; use Data::Dumper; package Pointy; sub new { my ( $class, $lat, $lon, $alt ) = @_; return bless { lat => $lat, lon => $lon, alt => $alt }, $class; } sub lat { shift->{lat} } sub lon { shift->{lon} } sub alt { shift->{alt} } package Pointy::Point; our @ISA = qw( Pointy ); sub latlong { my $self = shift; return $self->{lat}, $self->{lon}; } package main; my @case = ( { name => 'Simple', args => [ 54.786989, -2.344214 ], lat => 54.786989, lon => -2.344214, alt => undef, }, { name => 'Simple w/ alt', args => [ 54.786989, -2.344214, 120 ], lat => 54.786989, lon => -2.344214, alt => 120, }, { name => 'Array', args => [ [ 54.786989, -2.344214 ] ], lat => 54.786989, lon => -2.344214, alt => undef, }, { name => 'Hash, short names', args => [ { lat => 54.786989, lon => -2.344214 } ], lat => 54.786989, lon => -2.344214, alt => undef, }, { name => 'Hash, long names', args => [ { latitude => 54.786989, longitude => -2.344214, elevation => 3 } ], lat => 54.786989, lon => -2.344214, alt => 3, }, { name => 'Point object', args => [ new Pointy( 54.786989, -2.344214, 3 ) ], lat => 54.786989, lon => -2.344214, alt => 3, }, { name => 'Point object', args => [ new Pointy::Point( 54.786989, -2.344214 ) ], lat => 54.786989, lon => -2.344214, alt => undef, }, { name => 'URI::geo object', args => [ new URI::geo( 54.786989, -2.344214, 99 ) ], lat => 54.786989, lon => -2.344214, alt => 99, }, ); plan tests => @case * 5; for my $case ( @case ) { my ( $name, $args, $lat, $lon, $alt ) = @{$case}{ 'name', 'args', 'lat', 'lon', 'alt' }; ok my $guri = URI::geo->new( @$args ), "$name: created"; is $guri->scheme, 'geo', "$name: scheme"; is $guri->latitude, $lat, "$name: latitude"; is $guri->longitude, $lon, "$name: longitude"; is $guri->altitude, $alt, "$name: altitude"; } # vim:ts=2:sw=2:et:ft=perl ��rfc2732.t��0000644��00000003556�15125162450�0006033 0��ustar�00��# Test URIs containing IPv6 addresses use strict; use warnings; use Test::More tests => 19; use URI (); my $uri = URI->new("http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html"); is $uri->as_string, "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html"; is $uri->host, "FEDC:BA98:7654:3210:FEDC:BA98:7654:3210"; is $uri->host_port, "[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80"; is $uri->port, "80"; $uri->port(undef); is $uri->as_string, "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]/index.html"; is $uri->host_port, "[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80"; $uri->port(80); $uri->host("host"); is $uri->as_string, "http://host:80/index.html"; $uri->host("FEDC:BA98:7654:3210:FEDC:BA98:7654:3210"); is $uri->as_string, "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html"; $uri->host_port("[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:88"); is $uri->as_string, "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:88/index.html"; $uri->host_port("[::1]:80"); is $uri->as_string, "http://[::1]:80/index.html"; $uri->host("::1:80"); is $uri->as_string, "http://[::1:80]:80/index.html"; $uri->host("[::1:80]"); is $uri->as_string, "http://[::1:80]:80/index.html"; $uri->host("[::1]:88"); is $uri->as_string, "http://[::1]:88/index.html"; $uri = URI->new("ftp://ftp:@[3ffe:2a00:100:7031::1]"); is $uri->as_string, "ftp://ftp:@[3ffe:2a00:100:7031::1]"; is $uri->port, "21"; ok !$uri->_port; is $uri->host("ftp"), "3ffe:2a00:100:7031::1"; is $uri, "ftp://ftp:\@ftp"; $uri = URI->new("http://[::1]"); is $uri->host, "::1"; __END__ http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html http://[1080:0:0:0:8:800:200C:417A]/index.html http://[3ffe:2a00:100:7031::1] http://[1080::8:800:200C:417A]/foo http://[::192.9.5.5]/ipng http://[::FFFF:129.144.52.38]:80/index.html http://[2010:836B:4179::836B:4179] ��geo_basic.t��0000644��00000003346�15125162450�0006653 0��ustar�00��#!perl use strict; use warnings; use URI; use Test::More tests => 24; { ok my $guri = URI->new( 'geo:54.786989,-2.344214' ), 'created'; isa_ok $guri, 'URI::geo'; is $guri->scheme, 'geo', 'scheme'; is $guri->opaque, '54.786989,-2.344214', 'opaque'; is $guri->path, '54.786989,-2.344214', 'path'; is $guri->fragment, undef, 'fragment'; is $guri->latitude, 54.786989, 'latitude'; is $guri->longitude, -2.344214, 'longitude'; is $guri->altitude, undef, 'altitude'; is $guri->as_string, 'geo:54.786989,-2.344214', 'stringify'; $guri->altitude( 120 ); is $guri->altitude, 120, 'altitude set'; is $guri->as_string, 'geo:54.786989,-2.344214,120', 'stringify w/ alt'; $guri->latitude( 55.167469 ); $guri->longitude( -1.700663 ); is $guri->as_string, 'geo:55.167469,-1.700663,120', 'stringify updated w/ alt'; } { ok my $guri = URI->new( 'geo:55.167469,-1.700663,120' ), 'created'; my @loc = $guri->location; is_deeply [@loc], [ 55.167469, -1.700663, 120 ], 'got location'; } { ok my $guri = URI->new( 'geo:-33,30' ), 'created'; my @loc = $guri->location; is_deeply [@loc], [ -33, 30, undef ], 'got location'; } { ok my $guri = URI->new( 'geo:-33,30,12.3;crs=wgs84;u=12' ), 'created'; my @loc = $guri->location; is_deeply [@loc], [ -33, 30, 12.3 ], 'got location'; is $guri->crs, 'wgs84', 'crs'; is $guri->uncertainty, 12, 'u'; } { eval { URI->new( 'geo:1' ) }; like $@, qr/Badly formed/, 'error ok'; } { ok( URI->new( 'geo:55,1' )->eq( URI->new( 'geo:55,1' ) ), 'eq 1' ); ok( URI->new( 'geo:90,1' )->eq( URI->new( 'geo:90,2' ) ), 'eq 2' ); } # vim:ts=2:sw=2:et:ft=perl ��mix.t��0000644��00000002700�15125162450�0005526 0��ustar�00��use strict; use warnings; use Test::More tests => 6; # Test mixing of URI and URI::WithBase objects use URI (); use URI::WithBase (); use URI::URL (); my $str = "http://www.sn.no/"; my $rel = "path/img.gif"; my $u = URI->new($str); my $uw = URI::WithBase->new($str, "http:"); my $uu = URI::URL->new($str); my $a = URI->new($rel, $u); my $b = URI->new($rel, $uw); my $c = URI->new($rel, $uu); my $d = URI->new($rel, $str); sub Dump { require Data::Dumper; print Data::Dumper->Dump([$a, $b, $c, $d], [qw(a b c d)]); } #Dump(); ok($a->isa("URI") && ref($b) eq ref($uw) && ref($c) eq ref($uu) && $d->isa("URI")); ok(not $b->base && $c->base); $a = URI::URL->new($rel, $u); $b = URI::URL->new($rel, $uw); $c = URI::URL->new($rel, $uu); $d = URI::URL->new($rel, $str); ok(ref($a) eq "URI::URL" && ref($b) eq "URI::URL" && ref($c) eq "URI::URL" && ref($d) eq "URI::URL"); ok(ref($b->base) eq ref($uw) && $b->base eq $uw && ref($c->base) eq ref($uu) && $c->base eq $uu && $d->base eq $str); $a = URI->new($uu, $u); $b = URI->new($uu, $uw); $c = URI->new($uu, $uu); $d = URI->new($uu, $str); #Dump(); ok(ref($a) eq ref($b) && ref($b) eq ref($c) && ref($c) eq ref($d) && ref($d) eq ref($u)); $a = URI::URL->new($u, $u); $b = URI::URL->new($u, $uw); $c = URI::URL->new($u, $uu); $d = URI::URL->new($u, $str); ok(ref($a) eq "URI::URL" && ref($b) eq "URI::URL" && ref($c) eq "URI::URL" && ref($d) eq "URI::URL"); ��sq-brackets.t��0000644��00000020015�15125162450�0007147 0��ustar�00��use strict; use warnings; use Test::More; BEGIN { $ENV{URI_HAS_RESERVED_SQUARE_BRACKETS} = 0; } use URI (); sub show { diag explain("self: ", shift); } #-- test bugfix of https://github.com/libwww-perl/URI/issues/99 is( URI::HAS_RESERVED_SQUARE_BRACKETS, 0, "constant indicates NOT to treat square brackets as reserved characters" ); { my $u = URI->new("http://[::1]/path_with_square_[brackets]?par=value[1]"); is( $u->canonical, "http://[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D", "sqb in path and request" ) or show $u; } { my $u = URI->new("http://[::1]/path_with_square_[brackets]?par=value[1]#fragment[2]"); is( $u->canonical, "http://[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D#fragment%5B2%5D", "sqb in path and request and fragment" ) or show $u; } { my $u = URI->new("http://root[user]@[::1]/path_with_square_[brackets]?par=value[1]#fragment[2]"); is( $u->canonical, "http://root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D#fragment%5B2%5D", "sqb in userinfo, host, path, request and fragment" ) or show $u; } { my $u = URI->new("http://root[user]@[::1]/path_with_square_[brackets]?par=value[1]&par[2]=value[2]#fragment[2]"); is( $u->canonical, "http://root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D&par%5B2%5D=value%5B2%5D#fragment%5B2%5D", "sqb in userinfo, host, path, request and fragment" ) or show $u; is( $u->scheme() , "http", "scheme"); is( $u->userinfo() , "root%5Buser%5D", "userinfo"); is( $u->host() , "::1", "host"); is( $u->ihost() , "::1", "ihost"); is( $u->port() , "80", "port"); is( $u->default_port() , "80", "default_port"); is( $u->host_port() , "[::1]:80", "host_port"); is( $u->secure() , "0", "is_secure" ); is( $u->path() , "/path_with_square_%5Bbrackets%5D", "path"); is( $u->opaque() , "//root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D&par%5B2%5D=value%5B2%5D", "opaque"); is( $u->fragment() , "fragment%5B2%5D", "fragment"); is( $u->query() , "par=value%5B1%5D&par%5B2%5D=value%5B2%5D", "query"); is( $u->as_string() , "http://root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D&par%5B2%5D=value%5B2%5D#fragment%5B2%5D", "as_string"); is( $u->has_recognized_scheme() , "1", "has_recognized_scheme"); is( $u->as_iri() , "http://root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D&par%5B2%5D=value%5B2%5D#fragment%5B2%5D", "as_iri"); #TODO: utf8 is( $u->abs( "/BASEDIR")->as_string() , "http://root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D&par%5B2%5D=value%5B2%5D#fragment%5B2%5D", "abs (no change)"); is( $u->rel("../BASEDIR") , "http://root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D?par=value%5B1%5D&par%5B2%5D=value%5B2%5D#fragment%5B2%5D", "rel"); is( $u->authority() , "root%5Buser%5D@[::1]", "authority" ); is( $u->path_query() , "/path_with_square_%5Bbrackets%5D?par=value%5B1%5D&par%5B2%5D=value%5B2%5D", "path_query"); is( $u->query_keywords() , undef, "query_keywords"); my @segments = $u->path_segments(); is( join(" \| ", @segments), " \| path_with_square_[brackets]", "segments"); } { #-- form/query related tests my $u = URI->new("http://root[user]@[::1]/path_with_square_[brackets]/segment[2]?par=value[1]&par[2]=value[2]#fragment[2]"); is( $u->query_form(), "4", "scalar: query_form"); is( join(" \| ", $u->query_form()), "par \| value[1] \| par[2] \| value[2]", "list: query_form"); $u->query_form( {} ); is( $u->query(), undef, "query removed"); is( join(" \| ", $u->query_form()), "", "list: query_form"); is( $u->canonical(), "http://root%5Buser%5D@[::1]/path_with_square_%5Bbrackets%5D/segment%5B2%5D#fragment%5B2%5D", "query removed: canonical"); $u->query_form( key1 => 'val1', key2 => 'val[2]' ); is( $u->query(), "key1=val1&key2=val%5B2%5D", "query"); } { #-- path segments my $u = URI->new("http://root[user]@[::1]/path_with_square_[brackets]/segment[2]?par=value[1]#fragment[2]"); my @segments = $u->path_segments(); is( join(" \| ", @segments), " \| path_with_square_[brackets] \| segment[2]", "segments"); } { #-- rel my $u = URI->new("http://root[user]@[::1]/oldbase/next/path_with_square_[brackets]/segment[2]?par=value[1]#fragment[2]"); #TODO: is userinfo@ optional? is( $u->rel("http://root%5Buser%5D@[::1]/oldbase/next/")->canonical(), "path_with_square_%5Bbrackets%5D/segment%5B2%5D?par=value%5B1%5D#fragment%5B2%5D", "rel/canonical" ); } { #-- various setters my $ip6 = 'fedc:ba98:7654:3210:fedc:ba98:7654:3210'; my $u = URI->new("http://\[" . uc($ip6) . "\]/index.html"); is ($u->canonical(), "http://[$ip6]/index.html", "basic IPv6 URI"); $u->scheme("https"); is ($u->canonical(), "https://[$ip6]/index.html", "basic IPv6 URI"); $u->userinfo("user[42]"); #-- tolerate unescaped '[', ']' is ($u->canonical(), "https://user%5B42%5D@[$ip6]/index.html", "userinfo added (unescaped)"); is ($u->userinfo(), "user%5B42%5D", "userinfo is escaped"); $u->userinfo("user%5B77%5D"); #-- already escaped is ($u->canonical(), "https://user%5B77%5D@[$ip6]/index.html", "userinfo replaced (escaped)"); is ($u->userinfo(), "user%5B77%5D", "userinfo is escaped"); $u->userinfo( q(weird.al$!:secret[1]++) ); is ($u->canonical(), "https://weird.al\$!:secret%5B1%5D++@[$ip6]/index.html", "userinfo replaced (escaped2)"); is ($u->userinfo(), "weird.al\$!:secret%5B1%5D++", "userinfo is escaped2"); $u->userinfo( q(j.doe@example.com:secret) ); is ($u->canonical(), "https://j.doe%40example.com:secret@[$ip6]/index.html", "userinfo replaced (escaped3)"); is ($u->userinfo() , "j.doe%40example.com:secret", "userinfo is escaped3"); $u->host("example.com"); is ($u->canonical(), "https://j.doe%40example.com:secret\@example.com/index.html", "hostname replaced"); $u->host("127.0.0.1"); is ($u->canonical(), "https://j.doe%40example.com:secret\@127.0.0.1/index.html", "hostname replaced"); for my $host ( qw(example.com 127.0.0.1)) { $u->host( $host ); my $expect = "https://j.doe%40example.com:secret\@$host/index.html"; is ($u->canonical(), $expect, "host: $host"); is ($u->host(), $host, "same hosts ($host)"); } for my $host6 ( $ip6, qw(::1) ) { $u->host( $host6 ); my $expect = "https://j.doe%40example.com:secret\@[$host6]/index.html"; is ($u->canonical(), $expect, "IPv6 host: $host6"); is ($u->host(), $host6, "same IPv6 hosts ($host6)"); } $u->host($ip6); $u->path("/subdir/index[1].html"); is( $u->canonical(), "https://j.doe%40example.com:secret@[$ip6]/subdir/index%5B1%5D.html", "path replaced"); $u->fragment("fragment[xyz]"); is( $u->canonical(), "https://j.doe%40example.com:secret@[$ip6]/subdir/index%5B1%5D.html#fragment%5Bxyz%5D", "fragment added"); $u->authority("user[doe]@[::1]"); is( $u->canonical(), "https://user%5Bdoe%5D@[::1]/subdir/index%5B1%5D.html#fragment%5Bxyz%5D", "authority replaced"); $u->authority("::1"); is( $u->canonical(), "https://[::1]/subdir/index%5B1%5D.html#fragment%5Bxyz%5D", "authority replaced"); $u->authority("[::1]:19999"); is( $u->canonical(), "https://[::1]:19999/subdir/index%5B1%5D.html#fragment%5Bxyz%5D", "authority replaced"); # $u->authority("::1:18000"); #-- theoretically, we could guess an [::1]:18000 ... but for now it will just be ill formatted. # is( $u->canonical(), "https://::1:18000/subdir/index%5B1%5D.html#fragment%5Bxyz%5D", "authority replaced"); $u->authority("user[abc]\@::1"); is( $u->canonical(), "https://user%5Babc%5D@[::1]/subdir/index%5B1%5D.html#fragment%5Bxyz%5D", "authority replaced"); $u->authority("user[xyz]\@example.com\@[::1]:22022"); is( $u->canonical(), "https://user%5Bxyz%5D%40example.com@[::1]:22022/subdir/index%5B1%5D.html#fragment%5Bxyz%5D", "authority replaced"); } done_testing; ��geo_point.t��0000644��00000000655�15125162450�0006723 0��ustar�00��#!perl use strict; use warnings; use URI::geo; use Test::More; eval { require Geo::Point }; plan skip_all => 'Needs Geo::Point' if $@; plan tests => 5; ok my $pt = Geo::Point->latlong( 48.208333, 16.372778 ), 'point'; ok my $guri = URI::geo->new( $pt ), 'uri'; is $guri->latitude, 48.208333, 'latitude'; is $guri->longitude, 16.372778, 'longitude'; is $guri->altitude, undef, 'altitude'; # vim:ts=2:sw=2:et:ft=perl ��roytest5.html��0000644��00000006442�15125162450�0007237 0��ustar�00��<HTML><HEAD> <TITLE>Examples of Resolving Relative URLs, Part 5</TITLE> <BASE href="http:///s//a/b/c"> </HEAD><BODY> <H1>Examples of Resolving Relative URLs, Part 5</H1> This document has an embedded base URL of <PRE> Content-Base: http:///s//a/b/c </PRE> in order to test a notion that Tim Berners-Lee mentioned regarding the ability of URIs to have a triple-slash (or even more slashes) to indicate higher levels of hierarchy than those already used by URLs. This is the same as Part 4, except that the scheme "fred" is replaced with "http" for clients that stupidly change their parsing behavior based on the scheme name. <H2>Tested Clients and Client Libraries</H2> <DL COMPACT> <DT>[R] <DD>RFC 2396 (the right way to parse) <DT>Tim <DD>Tim Berners-Lee's proposed interpretation <DT>[1] <DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav) <DT>[2] <DD>Lynx/2.7.1 libwww-FM/2.14 <DT>[3] <DD>MSIE 3.01; Windows 95 <DT>[4] <DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) </DL> <H3>Synopsis</H3> RFC 1808 specified that the highest level for relative URLs is indicated by a double-slash "//", and therefore that any triple-slash would be considered a null site component, rather than a higher-level component than the site component (as proposed by Tim).<P> Draft 09 assumes that a triple-slash means an empty site component, as does Netscape Navigator if the scheme is known. Oddly, Lynx seems to straddle both sides. <H2>Examples</H2> <PRE> RESULTS from <a href="g:h">g:h</a> = g:h [R,Tim,2,3] http:///s//a/b/g:h [1] <a href="g">g</a> = http:///s//a/b/g [R,Tim,1,2,3] <a href="./g">./g</a> = http:///s//a/b/g [R,Tim,1,2,3] <a href="g/">g/</a> = http:///s//a/b/g/ [R,Tim,1,2,3] <a href="/g">/g</a> = http:///g [R,1,2,3] http:///s//a/g [Tim] <a href="//g">//g</a> = http://g [R,1,2,3] http:///s//g [Tim] <a href="//g/x">//g/x</a> = http://g/x [R,1,2,3] http:///s//g/x [Tim] <a href="///g">///g</a> = http:///g [R,Tim,1,2,3] <a href="./">./</a> = http:///s//a/b/ [R,Tim,1,2,3] <a href="../">../</a> = http:///s//a/ [R,Tim,1,2,3] <a href="../g">../g</a> = http:///s//a/g [R,Tim,1,2,3] <a href="../../">../../</a> = http:///s// [R,1] http:///s//a/../ [Tim,2] http:///s//a/ [3] <a href="../../g">../../g</a> = http:///s//g [R,1] http:///s//a/../g [Tim,2] http:///s//a/g [3] <a href="../../../g">../../../g</a> = http:///s/g [R,1] http:///s//a/../../g [Tim,2] http:///s//a/g [3] <a href="../../../../g">../../../../g</a> = http:///g [R,1] http:///s//a/../../../g [Tim,2] http:///s//a/g [3] </PRE> </BODY></HTML> ��abs.t��0000644��00000012704�15125162450�0005503 0��ustar�00��use strict; use warnings; use Test::More tests => 45; # This test the resolution of abs path for all examples given # in the "Uniform Resource Identifiers (URI): Generic Syntax" document. use URI (); my $base = "http://a/b/c/d;p?q"; my $testno = 1; my @rel_fail; while (<DATA>) { #next if 1 .. /^C\.\s+/; #last if /^D\.\s+/; next unless /\s+(\S+)\s=\s(.)/; my $uref = $1; my $expect = $2; $expect =~ s/\(current document\)/$base/; my $bad; my $u = URI->new($uref, $base); if ($u->abs($base)->as_string ne $expect) { $bad++; my $abs = $u->abs($base)->as_string; diag qq(URI->new("$uref")->abs("$base") ==> "$abs"); } # Let's test another version of the same thing $u = URI->new($uref); my $b = URI->new($base); if ($u->abs($b,1) ne $expect && $uref !~ /^http:/) { $bad++; diag qq(URI->new("$uref")->abs(URI->new("$base"), 1)); } # Let's try the other way $u = URI->new($expect)->rel($base)->as_string; if ($u ne $uref) { push(@rel_fail, qq($testno: URI->new("$expect", "$base")->rel ==> "$u" (not "$uref")\n)); } ok !$bad, "$uref => $expect"; } if (@rel_fail) { note "\n\nIn the following cases we did not get back to where we started with rel()"; note @rel_fail; } __END__ Network Working Group T. Berners-Lee, MIT/LCS INTERNET-DRAFT R. Fielding, U.C. Irvine draft-fielding-uri-syntax-02 L. Masinter, Xerox Corporation Expires six months after publication date March 4, 1998 Uniform Resource Identifiers (URI): Generic Syntax [...] C. Examples of Resolving Relative URI References Within an object with a well-defined base URI of http://a/b/c/d;p?q the relative URIs would be resolved as follows: C.1. Normal Examples g:h = g:h g = http://a/b/c/g ./g = http://a/b/c/g g/ = http://a/b/c/g/ /g = http://a/g //g = http://g ?y = http://a/b/c/d;p?y g?y = http://a/b/c/g?y #s = (current document)#s g#s = http://a/b/c/g#s g?y#s = http://a/b/c/g?y#s ;x = http://a/b/c/;x g;x = http://a/b/c/g;x g;x?y#s = http://a/b/c/g;x?y#s . = http://a/b/c/ ./ = http://a/b/c/ .. = http://a/b/ ../ = http://a/b/ ../g = http://a/b/g ../.. = http://a/ ../../ = http://a/ ../../g = http://a/g C.2. Abnormal Examples Although the following abnormal examples are unlikely to occur in normal practice, all URI parsers should be capable of resolving them consistently. Each example uses the same base as above. An empty reference refers to the start of the current document. <> = (current document) Parsers must be careful in handling the case where there are more relative path ".." segments than there are hierarchical levels in the base URI's path. Note that the ".." syntax cannot be used to change the authority component of a URI. ../../../g = http://a/../g ../../../../g = http://a/../../g In practice, some implementations strip leading relative symbolic elements (".", "..") after applying a relative URI calculation, based on the theory that compensating for obvious author errors is better than allowing the request to fail. Thus, the above two references will be interpreted as "http://a/g" by some implementations. Similarly, parsers must avoid treating "." and ".." as special when they are not complete components of a relative path. /./g = http://a/./g /../g = http://a/../g g. = http://a/b/c/g. .g = http://a/b/c/.g g.. = http://a/b/c/g.. ..g = http://a/b/c/..g Less likely are cases where the relative URI uses unnecessary or nonsensical forms of the "." and ".." complete path segments. ./../g = http://a/b/g ./g/. = http://a/b/c/g/ g/./h = http://a/b/c/g/h g/../h = http://a/b/c/h g;x=1/./y = http://a/b/c/g;x=1/y g;x=1/../y = http://a/b/c/y All client applications remove the query component from the base URI before resolving relative URIs. However, some applications fail to separate the reference's query and/or fragment components from a relative path before merging it with the base path. This error is rarely noticed, since typical usage of a fragment never includes the hierarchy ("/") character, and the query component is not normally used within relative references. g?y/./x = http://a/b/c/g?y/./x g?y/../x = http://a/b/c/g?y/../x g#s/./x = http://a/b/c/g#s/./x g#s/../x = http://a/b/c/g#s/../x Some parsers allow the scheme name to be present in a relative URI if it is the same as the base URI scheme. This is considered to be a loophole in prior specifications of partial URIs [RFC1630]. Its use should be avoided. http:g = http:g http: = http: -------------------------------------------------------------------------- Some extra tests for good measure... #foo? = (current document)#foo? ?#foo = http://a/b/c/d;p?#foo ��escape-char.t��0000644��00000001145�15125162450�0007106 0��ustar�00��use strict; use warnings; # see https://rt.cpan.org/Ticket/Display.html?id=96941 use Test::More; use URI (); TODO: { my $str = "http://foo/\xE9"; utf8::upgrade($str); my $uri = URI->new($str); local $TODO = 'URI::Escape::escape_char misunderstands utf8'; # http://foo/%C3%A9 is("$uri", 'http://foo/%E9', 'correctly created a URI from a utf8-upgraded string'); } { my $str = "http://foo/\xE9"; utf8::downgrade($str); my $uri = URI->new($str); # http://foo/%E9 is("$uri", 'http://foo/%E9', 'correctly created a URI from a utf8-downgrade string'); } done_testing; ��userpass.t��0000644��00000000655�15125162450�0006605 0��ustar�00��use strict; use warnings; use Test::More; use URI; my $uri = URI->new('rsync://foo:bar@example.com'); like $uri->as_string, qr/foo:bar\@example\.com/, 'userinfo is included'; $uri->password(undef); like $uri->as_string, qr/foo\@example\.com/, 'set password to undef'; $uri = URI->new('rsync://0:bar@example.com'); $uri->password(undef); like $uri->as_string, qr/0\@example\.com/, '... also for username "0"'; done_testing; ��mailto.t��0000644��00000004534�15125162450�0006225 0��ustar�00��use strict; use warnings; use Test::More; use URI (); my $u = URI->new('mailto:gisle@aas.no'); is $u->to, 'gisle@aas.no', 'parsing normal URI sets to()'; is $u, 'mailto:gisle@aas.no', '... and stringification works'; my $old = $u->to('larry@wall.org'); is $old, 'gisle@aas.no', 'to() returns old value'; is $u->to, 'larry@wall.org', '... and sets new value'; is $u, 'mailto:larry@wall.org', '... and stringification works'; $u->to("?/#"); is $u->to, "?/#", 'to() accepts chars that need escaping'; is $u, 'mailto:%3F/%23', '... and stringification escapes them'; my @h = $u->headers; ok @h == 2 && "@h" eq "to ?/#", '... and headers() returns the correct values'; $u->headers( to => 'gisle@aas.no', cc => 'gisle@ActiveState.com,larry@wall.org', Subject => 'How do you do?', garbage => '/;?#=&', ); @h = $u->headers; ok @h == 8 && "@h" eq 'to gisle@aas.no cc gisle@ActiveState.com,larry@wall.org Subject How do you do? garbage /;?#=&', 'setting multiple headers at once works'; is $u->to, 'gisle@aas.no', '... and to() returns the new value'; #print "$u\n"; is $u, 'mailto:gisle@aas.no?cc=gisle%40ActiveState.com%2Clarry%40wall.org&Subject=How+do+you+do%3F&garbage=%2F%3B%3F%23%3D%26', '... and stringification works'; $u = URI->new("mailto:"); $u->to("gisle"); is $u, 'mailto:gisle', 'starting with an empty URI and setting to() works'; $u = URI->new('mailto:user+detail@example.com'); is $u->to, 'user+detail@example.com', 'subaddress with `+` parsed correctly'; is $u, 'mailto:user+detail@example.com', '... and stringification works'; TODO: { local $TODO = "We can't handle quoted local parts without properly parsing the email addresses"; $u = URI->new('mailto:"foo bar+baz"@example.com'); is $u->to, '"foo bar+baz"@example.com', 'address with quoted local part containing spaces is parsed correctly'; is $u, 'mailto:%22foo%20bar+baz%22@example.com', '... and stringification works'; } # RFC 5321 (4.1.3) - Address Literals # IPv4 $u = URI->new('mailto:user@[127.0.0.1]'); is $u->to, 'user@[127.0.0.1]', 'IPv4 host name'; is $u, 'mailto:user@[127.0.0.1]', '... and stringification works'; # IPv6 $u = URI->new('mailto:user@[IPv6:fe80::e828:209d:20e:c0ae]'); is $u->to, 'user@[IPv6:fe80::e828:209d:20e:c0ae]', 'IPv4 host name'; is $u, 'mailto:user@[IPv6:fe80::e828:209d:20e:c0ae]', '... and stringification works'; done_testing; ��roytest4.html��0000644��00000007210�15125162450�0007230 0��ustar�00��<HTML><HEAD> <TITLE>Examples of Resolving Relative URLs, Part 4</TITLE> <BASE href="fred:///s//a/b/c"> </HEAD><BODY> <H1>Examples of Resolving Relative URLs, Part 4</H1> This document has an embedded base URL of <PRE> Content-Base: fred:///s//a/b/c </PRE> in order to test a notion that Tim Berners-Lee mentioned regarding the ability of URIs to have a triple-slash (or even more slashes) to indicate higher levels of hierarchy than those already used by URLs. <H2>Tested Clients and Client Libraries</H2> <DL COMPACT> <DT>[R] <DD>RFC 2396 (the right way to parse) <DT>Tim <DD>Tim Berners-Lee's proposed interpretation <DT>[1] <DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav) <DT>[2] <DD>Lynx/2.7.1 libwww-FM/2.14 <DT>[3] <DD>MSIE 3.01; Windows 95 <DT>[4] <DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) </DL> <H3>Synopsis</H3> RFC 1808 specified that the highest level for relative URLs is indicated by a double-slash "//", and therefore that any triple-slash would be considered a null site component, rather than a higher-level component than the site component (as proposed by Tim).<P> The URI draft assumes that a triple-slash means an empty site component. Netscape Navigator behaves irrationally, apparently because their parser is scheme-dependent and therefore doesn't do the hierarchical parsing that would be expected. Oddly, Lynx seems to straddle both sides. <H2>Examples</H2> <PRE> RESULTS from <a href="g:h">g:h</a> = g:h [R,Tim,2,3] fred:///s//a/b/g:h [1] <a href="g">g</a> = fred:///s//a/b/g [R,Tim,1,2,3] <a href="./g">./g</a> = fred:///s//a/b/g [R,Tim,2,3] fred:///s//a/b/./g [1] <a href="g/">g/</a> = fred:///s//a/b/g/ [R,Tim,1,2,3] <a href="/g">/g</a> = fred:///g [R,1,2,3] fred:///s//a/g [Tim] <a href="//g">//g</a> = fred://g [R,1,2,3] fred:///s//g [Tim] <a href="//g/x">//g/x</a> = fred://g/x [R,1,2,3] fred:///s//g/x [Tim] <a href="///g">///g</a> = fred:///g [R,Tim,1,2,3] <a href="./">./</a> = fred:///s//a/b/ [R,Tim,2,3] fred:///s//a/b/./ [1] <a href="../">../</a> = fred:///s//a/ [R,Tim,2,3] fred:///s//a/b/../ [1] <a href="../g">../g</a> = fred:///s//a/g [R,Tim,2,3] fred:///s//a/b/../g [1] <a href="../../">../../</a> = fred:///s// [R] fred:///s//a/../ [Tim,2] fred:///s//a/b/../../ [1] fred:///s//a/ [3] <a href="../../g">../../g</a> = fred:///s//g [R] fred:///s//a/../g [Tim,2] fred:///s//a/b/../../g [1] fred:///s//a/g [3] <a href="../../../g">../../../g</a> = fred:///s/g [R] fred:///s//a/../../g [Tim,2] fred:///s//a/b/../../../g [1] fred:///s//a/g [3] <a href="../../../../g">../../../../g</a> = fred:///g [R] fred:///s//a/../../../g [Tim,2] fred:///s//a/b/../../../../g [1] fred:///s//a/g [3] </PRE> </BODY></HTML> ��rtsp.t��0000644��00000001213�15125162450�0005717 0��ustar�00��use strict; use warnings; use Test::More tests => 9; use URI (); my $u = URI->new("<rtsp://media.example.com/f�o.smi/>"); #print "$u\n"; is($u, "rtsp://media.example.com/f%F4o.smi/"); is($u->port, 554); # play with port my $old = $u->port(8554); ok($old == 554 && $u eq "rtsp://media.example.com:8554/f%F4o.smi/"); $u->port(554); is($u, "rtsp://media.example.com:554/f%F4o.smi/"); $u->port(""); ok($u eq "rtsp://media.example.com:/f%F4o.smi/" && $u->port == 554); $u->port(undef); is($u, "rtsp://media.example.com/f%F4o.smi/"); is($u->host, "media.example.com"); is($u->path, "/f%F4o.smi/"); $u->scheme("rtspu"); is($u->scheme, "rtspu"); ��news.t��0000644��00000002017�15125162450�0005706 0��ustar�00��use strict; use warnings; use Test::More tests => 8; use URI (); my $u = URI->new("news:comp.lang.perl.misc"); ok($u->group eq "comp.lang.perl.misc" && !defined($u->message) && $u->port == 119 && $u eq "news:comp.lang.perl.misc"); $u->host("news.online.no"); ok($u->group eq "comp.lang.perl.misc" && $u->port == 119 && $u eq "news://news.online.no/comp.lang.perl.misc"); $u->group("no.perl", 1 => 10); is($u, "news://news.online.no/no.perl/1-10"); my @g = $u->group; is_deeply(\@g, ["no.perl", 1, 10]); $u->message('42@g.aas.no'); #print "$u\n"; ok($u->message eq '42@g.aas.no' && !defined($u->group) && $u eq 'news://news.online.no/42@g.aas.no'); $u = URI->new("nntp:no.perl"); ok($u->group eq "no.perl" && $u->port == 119); $u = URI->new("snews://snews.online.no/no.perl"); ok($u->group eq "no.perl" && $u->host eq "snews.online.no" && $u->port == 563); $u = URI->new("nntps://nntps.online.no/no.perl"); ok($u->group eq "no.perl" && $u->host eq "nntps.online.no" && $u->port == 563); ��query-param.t��0000644��00000003727�15125162450�0007206 0��ustar�00��use strict; use warnings; use Test::More tests => 20; use URI (); use URI::QueryParam; my $u = URI->new("http://www.sol.no?foo=4&bar=5&foo=5"); is_deeply( $u->query_form_hash, { foo => [ 4, 5 ], bar => 5 }, 'query_form_hash get' ); $u->query_form_hash({ a => 1, b => 2}); ok $u->query eq "a=1&b=2" \|\| $u->query eq "b=2&a=1", 'query_form_hash set'; $u->query("a=1&b=2&a=3&b=4&a=5"); is join(':', $u->query_param), "a:b", 'query_param list keys'; is $u->query_param("a"), "1", "query_param scalar return"; is join(":", $u->query_param("a")), "1:3:5", "query_param list return"; is $u->query_param(a => 11 .. 15), 1, "query_param set return"; is $u->query, "a=11&b=2&a=12&b=4&a=13&a=14&a=15", "param order"; is join(":", $u->query_param(a => 11)), "11:12:13:14:15", "old values returned"; is $u->query, "a=11&b=2&b=4"; is $u->query_param_delete("a"), "11", 'query_param_delete'; is $u->query, "b=2&b=4"; $u->query_param_append(a => 1, 3, 5); $u->query_param_append(b => 6); is $u->query, "b=2&b=4&a=1&a=3&a=5&b=6"; $u->query_param(a => []); # same as $u->query_param_delete("a"); is $u->query, "b=2&b=4&b=6", 'delete by assigning empty list'; $u->query(undef); $u->query_param(a => 1, 2, 3); $u->query_param(b => 1); is $u->query, 'a=1&a=2&a=3&b=1', 'query_param from scratch'; $u->query_param_delete('a'); $u->query_param_delete('b'); ok ! $u->query; is $u->as_string, 'http://www.sol.no'; $u->query(undef); $u->query_param(a => 1, 2, 3); $u->query_param(b => 1); is $u->query, 'a=1&a=2&a=3&b=1'; $u->query_param('a' => []); $u->query_param('b' => []); ok ! $u->query; # Same, but using array object { package Foo::Bar::Array; sub new { my $this = shift( @_ ); return( bless( ( @_ == 1 && ref( $_[0] \|\| '' ) eq 'ARRAY' ) ? shift( @_ ) : [@_] => ( ref( $this ) \|\| $this ) ) ); } } $u->query_param('a' => Foo::Bar::Array->new); $u->query_param('b' => Foo::Bar::Array->new); ok ! $u->query; is $u->as_string, 'http://www.sol.no'; ��ipv6.t��0000644��00000000334�15125162450�0005616 0��ustar�00��use strict; use warnings; use URI (); use Test::More; my $url = URI->new('http://[fe80::e828:209d:20e:c0ae]:375'); is( $url->host, 'fe80::e828:209d:20e:c0ae', 'host' ); is( $url->port, 375, 'port' ); done_testing(); ��storable.t��0000644��00000000352�15125162450�0006545 0��ustar�00��use strict; use warnings; use Test::Needs 'Storable'; my $inc = -d "blib/lib" ? "blib/lib" : "lib"; system($^X, "-I$inc", "t/storable-test.pl", "store"); system($^X, "-I$inc", "t/storable-test.pl", "retrieve"); unlink('urls.sto'); ��ldap.t��0000644��00000004607�15125162450�0005661 0��ustar�00��use strict; use warnings; use Test::More tests => 24; use URI (); my $uri; $uri = URI->new("ldap://host/dn=base?cn,sn?sub?objectClass="); is($uri->host, "host"); is($uri->dn, "dn=base"); is(join("-",$uri->attributes), "cn-sn"); is($uri->scope, "sub"); is($uri->filter, "objectClass="); $uri = URI->new("ldap:"); $uri->dn("o=University of Michigan,c=US"); ok("$uri" eq "ldap:o=University%20of%20Michigan,c=US" && $uri->dn eq "o=University of Michigan,c=US"); $uri->host("ldap.itd.umich.edu"); is($uri->as_string, "ldap://ldap.itd.umich.edu/o=University%20of%20Michigan,c=US"); # check defaults ok($uri->_scope eq "" && $uri->scope eq "base" && $uri->_filter eq "" && $uri->filter eq "(objectClass=)"); # attribute $uri->attributes("postalAddress"); is($uri, "ldap://ldap.itd.umich.edu/o=University%20of%20Michigan,c=US?postalAddress"); # does attribute escapeing work as it should $uri->attributes($uri->attributes, "foo", ",", "", "?", "#", "\0"); ok($uri->attributes eq "postalAddress,foo,%2C,,%3F,%23,%00" && join("-", $uri->attributes) eq "postalAddress-foo-,--?-#-\0"); $uri->attributes(""); $uri->scope("sub?#"); ok($uri->query eq "?sub%3F%23" && $uri->scope eq "sub?#"); $uri->scope(""); $uri->filter("f=?,#"); ok($uri->query eq "??f=%3F,%23" && $uri->filter eq "f=?,#"); $uri->filter("(int=\\00\\00\\00\\04)"); is($uri->query, "??(int=%5C00%5C00%5C00%5C04)"); $uri->filter(""); $uri->extensions("!bindname" => "cn=Manager,co=Foo"); my %ext = $uri->extensions; ok($uri->query eq "???!bindname=cn=Manager%2Cco=Foo" && keys %ext == 1 && $ext{"!bindname"} eq "cn=Manager,co=Foo"); $uri = URI->new("ldap://LDAP-HOST:389/o=University%20of%20Michigan,c=US?postalAddress?base?ObjectClass=?FOO=Bar,bindname=CN%3DManager%CO%3dFoo"); is($uri->canonical, "ldap://ldap-host/o=University%20of%20Michigan,c=US?postaladdress???foo=Bar,bindname=CN=Manager%CO=Foo"); note $uri; note $uri->canonical; ok(!$uri->secure); $uri = URI->new("ldaps://host/dn=base?cn,sn?sub?objectClass="); is($uri->host, "host"); is($uri->port, 636); is($uri->dn, "dn=base"); ok($uri->secure); $uri = URI->new("ldapi://%2Ftmp%2Fldap.sock/????x-mod=-w--w----"); is($uri->authority, "%2Ftmp%2Fldap.sock"); is($uri->un_path, "/tmp/ldap.sock"); $uri->un_path("/var/x\@foo:bar/"); is($uri, "ldapi://%2Fvar%2Fx%40foo%3Abar%2F/????x-mod=-w--w----"); %ext = $uri->extensions; is($ext{"x-mod"}, "-w--w----"); ��icap.t��0000644��00000002121�15125162450�0005642 0��ustar�00��use strict; use warnings; use Test::More tests => 16; use URI (); my $u = URI->new("<icap://www.example.com/path?q=f�o>"); is($u, "icap://www.example.com/path?q=f%F4o"); is($u->port, 1344); # play with port my $old = $u->port(8080); ok($old == 1344 && $u eq "icap://www.example.com:8080/path?q=f%F4o"); $u->port(1344); is($u, "icap://www.example.com:1344/path?q=f%F4o"); $u->port(""); ok($u eq "icap://www.example.com:/path?q=f%F4o" && $u->port == 1344); $u->port(undef); is($u, "icap://www.example.com/path?q=f%F4o"); my @q = $u->query_form; is_deeply(\@q, ["q", "f�o"]); $u->query_form(foo => "bar", bar => "baz"); is($u->query, "foo=bar&bar=baz"); is($u->host, "www.example.com"); is($u->path, "/path"); ok(!$u->secure); $u->scheme("icaps"); is($u->port, 1344); is($u, "icaps://www.example.com/path?foo=bar&bar=baz"); ok($u->secure); $u = URI->new("icaps://%65%78%61%6d%70%6c%65%2e%63%6f%6d/%70%75%62/%61/%32%30%30%31/%30%38/%32%37/%62%6a%6f%72%6e%73%74%61%64%2e%68%74%6d%6c"); is($u->canonical, "icaps://example.com/pub/a/2001/08/27/bjornstad.html"); ok($u->has_recognized_scheme); ��old-file.t��0000644��00000005333�15125162450�0006431 0��ustar�00��use strict; use warnings; use Test::More; use URI::file (); $URI::file::DEFAULT_AUTHORITY = undef; my @tests = ( [ "file", "unix", "win32", "mac" ], #---------------- ------------ --------------- -------------- [ "file://localhost/foo/bar", "!/foo/bar", "!\\foo\\bar", "!foo:bar", ], [ "file:///foo/bar", "!/foo/bar", "!\\foo\\bar", "!foo:bar", ], [ "file:/foo/bar", "/foo/bar", "\\foo\\bar", "foo:bar", ], [ "foo/bar", "foo/bar", "foo\\bar", ":foo:bar",], [ "file://foo3445x/bar","!//foo3445x/bar", "\\\\foo3445x\\bar", "!foo3445x:bar"], [ "file://a:/", "!//a:/", "!A:\\", undef], [ "file:/", "/", "\\", undef], [ "file://A:relative/", "!//A:relative/", "A:", undef], [ ".", ".", ".", ":"], [ "..", "..", "..", "::"], [ "%2E", "!.", "!.", ":."], [ "../%2E%2E", "!../..", "!..\\..", "::.."], ); if ($^O eq "MacOS") { my @extratests = ( [ "../..", "../..", "..\\..", ":::"], [ "../../", "../../", "..\\..\\", "!:::"], [ "file:./foo.bar", "!./foo.bar", "!.\\foo.bar", "!:foo.bar"], [ "file:/%2Ffoo/bar", undef, undef, "/foo:bar"], [ "file:/.%2Ffoo/bar", undef, undef, "./foo:bar"], [ "file:/fee/.%2Ffoo%2Fbar", undef, undef, "fee:./foo/bar"], [ "file:/.%2Ffoo%2Fbar/", undef, undef, "./foo/bar:"], [ "file:/.%2Ffoo%2Fbar", undef, undef, "!./foo/bar:"], [ "file:/%2E%2E/foo", "!/../foo", "!\\..\\foo" , "..:foo"], [ "file:/bar/%2E/foo", "!/bar/./foo", "!\\bar\\.\\foo", "bar:.:foo"], [ "file:/foo/../bar", "/foo/../bar", "\\foo\\..\\bar", "foo::bar"], [ "file:/a/b/../../c/d", "/a/b/../../c/d", "\\a\\b\\..\\..\\c\\d", "a:b:::c:d"], ); push(@tests,@extratests); } my @os = @{shift @tests}; shift @os; # file plan tests => scalar @tests; for my $t (@tests) { my @t = @$t; my $file = shift @t; my $err; my $u = URI->new($file, "file"); my $i = 0; for my $os (@os) { my $f = $u->file($os); my $expect = $t[$i]; $f = "<undef>" unless defined $f; $expect = "<undef>" unless defined $expect; my $loose; $loose++ if $expect =~ s/^!//; if ($expect ne $f) { diag "URI->new('$file', 'file')->file('$os') ne $expect, but $f"; $err++; } if (defined($t[$i]) && !$loose) { my $u2 = URI::file->new($t[$i], $os); unless ($u2->as_string eq $file) { diag "URI::file->new('$t[$i]', '$os') ne $file, but $u2"; $err++; } } $i++; } ok !$err; } ��old-base.t��0000644��00000104044�15125162450�0006423 0��ustar�00��use strict; use warnings; use Test::More 0.96; use URI::URL qw( url ); use URI::Escape qw(uri_escape uri_unescape); use File::Temp qw(tempdir); # want compatibility use URI::file (); $URI::file::DEFAULT_AUTHORITY = undef; package main; # Must ensure that there is no relative paths in @INC because we will # chdir in the newlocal tests. unless ($^O eq "MacOS") { chomp(my $pwd = ($^O =~ /mswin32/i ? `cd` : $^O eq 'VMS' ? `show default` : `pwd`)); if ($^O eq 'VMS') { $pwd =~ s#^\s+##; $pwd = VMS::Filespec::unixpath($pwd); $pwd =~ s#/$##; } for (@INC) { my $x = $_; $x = VMS::Filespec::unixpath($x) if $^O eq 'VMS'; next if $x =~ m\|^/\| or $^O =~ /os2\|mswin32/i and $x =~ m#^(\w:[\\/]\|[\\/]{2})#; note "Turn lib path $x into $pwd/$x\n"; $_ = "$pwd/$x"; } } $\| = 1; # Do basic tests first. note "Self tests for URI::URL version $URI::URL::VERSION...\n"; subtest 'scheme tests' => \&scheme_parse_test; subtest 'parts test' => \&parts_test; subtest 'escape test' => \&escape_test; subtest 'newlocal test' => \&newlocal_test; subtest 'Test relative/absolute URI::URL parsing' => \&absolute_test; subtest 'eq test' => \&eq_test; # Let's test making our own things URI::URL::strict(0); # This should work after URI::URL::strict(0) my $url = new URI::URL "x-myscheme:something"; # Since no implementor is registered for 'x-myscheme' then it will # be handled by the URI::URL::_generic class is($url->as_string, 'x-myscheme:something', ref($url) . '->as_string'); is($url->path, 'something', ref($url) . '->path'); URI::URL::strict(1); =comment # Let's try to make our URL subclass { package MyURL; @ISA = URI::URL::implementor(); sub _parse { my($self, $init) = @_; $self->URI::URL::_generic::_parse($init, qw(netloc path)); } sub foo { my $self = shift; print ref($self)."->foo called for $self\n"; } } # Let's say that it implements the 'x-a+b.c' scheme (alias 'x-foo') URI::URL::implementor('x-a+b.c', 'MyURL'); URI::URL::implementor('x-foo', 'MyURL'); # Now we are ready to try our new URL scheme $url = new URI::URL 'x-a+b.c://foo/bar;a?b'; is($url->as_string, 'x-a+b.c://foo/bar;a?b', ref($url) . '->as_string'); is($url->path, '/bar;a?b', ref($url) . '->path'); $url->foo; $newurl = new URI::URL 'xxx', $url; $newurl->foo; $url = new URI::URL 'yyy', 'x-foo:'; $url->foo; =cut # Test the new wash&go constructor is(url("../foo.html", "http://www.sn.no/a/b")->abs->as_string, 'http://www.sn.no/foo.html', 'wash&go'); note "URI::URL version $URI::URL::VERSION ok\n"; done_testing; exit 0; ##################################################################### # # scheme_parse_test() # # test parsing and retrieval methods sub scheme_parse_test { my $tests = { 'hTTp://web1.net/a/b/c/welcome#intro' => { 'scheme'=>'http', 'host'=>'web1.net', 'port'=>80, 'path'=>'/a/b/c/welcome', 'frag'=>'intro','query'=>undef, 'epath'=>'/a/b/c/welcome', 'equery'=>undef, 'params'=>undef, 'eparams'=>undef, 'as_string'=>'http://web1.net/a/b/c/welcome#intro', 'full_path' => '/a/b/c/welcome' }, 'http://web:1/a?query+text' => { 'scheme'=>'http', 'host'=>'web', 'port'=>1, 'path'=>'/a', 'frag'=>undef, 'query'=>'query+text' }, 'http://web.net/' => { 'scheme'=>'http', 'host'=>'web.net', 'port'=>80, 'path'=>'/', 'frag'=>undef, 'query'=>undef, 'full_path' => '/', 'as_string' => 'http://web.net/' }, 'http://web.net' => { 'scheme'=>'http', 'host'=>'web.net', 'port'=>80, 'path'=>'/', 'frag'=>undef, 'query'=>undef, 'full_path' => '/', 'as_string' => 'http://web.net/' }, 'http:0' => { 'scheme'=>'http', 'path'=>'0', 'query'=>undef, 'as_string'=>'http:0', 'full_path'=>'0', }, 'http:/0?0' => { 'scheme'=>'http', 'path'=>'/0', 'query'=>'0', 'as_string'=>'http:/0?0', 'full_path'=>'/0?0', }, 'http://0:0/0/0;0?0#0' => { 'scheme'=>'http', 'host'=>'0', 'port'=>'0', 'path' => '/0/0', 'query'=>'0', 'params'=>'0', 'netloc'=>'0:0', 'frag'=>0, 'as_string'=>'http://0:0/0/0;0?0#0' }, 'ftp://0%3A:%40@h:0/0?0' => { 'scheme'=>'ftp', 'user'=>'0:', 'password'=>'@', 'host'=>'h', 'port'=>'0', 'path'=>'/0?0', 'query'=>'0', params=>undef, 'netloc'=>'0%3A:%40@h:0', 'as_string'=>'ftp://0%3A:%40@h:0/0?0' }, 'ftp://usr:pswd@web:1234/a/b;type=i' => { 'host'=>'web', 'port'=>1234, 'path'=>'/a/b', 'user'=>'usr', 'password'=>'pswd', 'params'=>'type=i', 'as_string'=>'ftp://usr:pswd@web:1234/a/b;type=i' }, 'ftp://host/a/b' => { 'host'=>'host', 'port'=>21, 'path'=>'/a/b', 'user'=>'anonymous', 'as_string'=>'ftp://host/a/b' }, 'file://host/fseg/fs?g/fseg' # don't escape ? for file: scheme => { 'host'=>'host', 'path'=>'/fseg/fs', 'as_string'=>'file://host/fseg/fs?g/fseg' }, 'gopher://host' => { 'gtype'=>'1', 'as_string' => 'gopher://host', }, 'gopher://host/' => { 'gtype'=>'1', 'as_string' => 'gopher://host/', }, 'gopher://gopher/2a_selector' => { 'gtype'=>'2', 'selector'=>'a_selector', 'as_string' => 'gopher://gopher/2a_selector', }, 'mailto:libwww-perl@ics.uci.edu' => { 'address' => 'libwww-perl@ics.uci.edu', 'encoded822addr'=> 'libwww-perl@ics.uci.edu', # 'user' => 'libwww-perl', # 'host' => 'ics.uci.edu', 'as_string' => 'mailto:libwww-perl@ics.uci.edu', }, 'news:' => { 'groupart'=>'', 'group'=>'', as_string=>'news:' }, 'news:comp.lang.perl' => { 'group'=>'comp.lang.perl' }, 'news:perl-faq/module-list-1-794455075@ig.co.uk' => { 'article'=> 'perl-faq/module-list-1-794455075@ig.co.uk' }, 'nntp://news.com/comp.lang.perl/42' => { 'group'=>'comp.lang.perl', }, #'digits'=>42 }, 'telnet://usr:pswd@web:12345/' => { 'user'=>'usr', 'password'=>'pswd', 'host'=>'web' }, 'rlogin://aas@a.sn.no' => { 'user'=>'aas', 'host'=>'a.sn.no' }, # 'tn3270://aas@ibm' # => { 'user'=>'aas', 'host'=>'ibm', # 'as_string'=>'tn3270://aas@ibm/'}, # 'wais://web.net/db' # => { 'database'=>'db' }, # 'wais://web.net/db?query' # => { 'database'=>'db', 'query'=>'query' }, # 'wais://usr:pswd@web.net/db/wt/wp' # => { 'database'=>'db', 'wtype'=>'wt', 'wpath'=>'wp', # 'password'=>'pswd' }, }; foreach my $url_str (sort keys %$tests ){ note "Testing '$url_str'\n"; my $url = new URI::URL $url_str; my $tests = $tests->{$url_str}; while( my ($method, $exp) = each %$tests ){ is($url->$method, $exp, ref($url) . "->$method"); } } } ##################################################################### # # parts_test() (calls netloc_test test) # # Test individual component part access functions # sub parts_test { # test storage part access/edit methods (netloc, user, password, # host and port are tested by &netloc_test) $url = new URI::URL 'file://web/orig/path'; $url->scheme('http'); $url->path('1info'); $url->query('key words'); $url->frag('this'); is($url->as_string, 'http://web/1info?key%20words#this', ref($url) . '->as_string'); $url->epath('%2f/%2f'); $url->equery('a=%26'); is($url->full_path, '/%2f/%2f?a=%26', ref($url) . '->full_path'); # At this point it should be impossible to access the members path() # and query() without complaints. eval { my $p = $url->path; note "Path is $p\n"; }; fail "Path exception failed" unless $@; eval { my $p = $url->query; note "Query is $p\n"; }; fail "Query exception failed" unless $@; # but we should still be able to set it $url->path("howdy"); is($url->as_string, 'http://web/howdy?a=%26#this', ref($url) . '->as_string'); # Test the path_components function $url = new URI::URL 'file:%2f/%2f'; my $p; $p = join('-', $url->path_components); fail "\$url->path_components returns '$p', expected '/-/'" unless $p eq "/-/"; $url->host("localhost"); $p = join('-', $url->path_components); fail "\$url->path_components returns '$p', expected '-/-/'" unless $p eq "-/-/"; $url->epath("/foo/bar/"); $p = join('-', $url->path_components); fail "\$url->path_components returns '$p', expected '-foo-bar-'" unless $p eq "-foo-bar-"; $url->path_components("", "/etc", "\0", "..", "�se", ""); is($url->full_path, '/%2Fetc/%00/../%F8se/', ref($url) . '->full_path'); # Setting undef $url = new URI::URL 'http://web/p;p?q#f'; $url->epath(undef); $url->equery(undef); $url->eparams(undef); $url->frag(undef); is($url->as_string, 'http://web', ref($url) . '->as_string'); # Test http query access methods $url->keywords('dog'); is($url->as_string, 'http://web?dog', ref($url) . '->as_string'); $url->keywords(qw(dog bones)); is($url->as_string, 'http://web?dog+bones', ref($url) . '->as_string'); $url->keywords(0,0); is($url->as_string, 'http://web?0+0', ref($url) . '->as_string'); $url->keywords('dog', 'bones', '#+='); is($url->as_string, 'http://web?dog+bones+%23%2B%3D', ref($url) . '->as_string'); $a = join(":", $url->keywords); is($a, 'dog:bones:#+=', "\$url->keywords"); # calling query_form is an error # eval { my $foo = $url->query_form; }; # fail "\$url->query_form should croak since query contains keywords not a form." # unless $@; $url->query_form(a => 'foo', b => 'bar'); is($url->as_string, 'http://web?a=foo&b=bar', ref($url) . '->as_string'); my %a = $url->query_form; is_deeply( \%a, { a => 'foo', b => 'bar' }, "\$url->query_form", ); $url->query_form(a => undef, a => 'foo', '&=' => '&=+'); is($url->as_string, 'http://web?a&a=foo&%26%3D=%26%3D%2B', ref($url) . '->as_string'); my @a = $url->query_form; is(scalar(@a), 6, 'length'); is_deeply( \@a, [ 'a', undef, 'a', 'foo', '&=', '&=+', ], 'query_form', ); # calling keywords is an error # eval { my $foo = $url->keywords; }; # die "\$url->keywords should croak when query is a form" # unless $@; # Try this odd one $url->equery('&=&=b&a=&a&a=b=c&&a=b'); @a = $url->query_form; #note join(":", @a), "\n"; is(scalar(@a), 16, 'length'); ok( $a[4] eq "" && $a[5] eq "b" && $a[10] eq "a" && $a[11] eq "b=c", 'sequence', ); # Try array ref values in the key value pairs $url->query_form(a => ['foo', 'bar'], b => 'foo', c => ['bar', 'foo']); is($url->as_string, 'http://web?a=foo&a=bar&b=foo&c=bar&c=foo', ref($url) . '->as_string'); # Same, but using array object { package Foo::Bar::Array; sub new { my $this = shift( @_ ); return( bless( ( @_ == 1 && ref( $_[0] \|\| '' ) eq 'ARRAY' ) ? shift( @_ ) : [@_] => ( ref( $this ) \|\| $this ) ) ); } } $url->query_form(a => Foo::Bar::Array->new(['foo', 'bar']), b => 'foo', c => Foo::Bar::Array->new(['bar', 'foo'])); is($url->as_string, 'http://web?a=foo&a=bar&b=foo&c=bar&c=foo', ref($url) . '->as_string'); subtest 'netloc_test' => \&netloc_test; subtest 'port_test' => \&port_test; $url->query(undef); is($url->query, undef, ref($url) . '->as_string'); $url = new URI::URL 'gopher://gopher/'; $url->port(33); $url->gtype("3"); $url->selector("S"); $url->search("query"); is($url->as_string, 'gopher://gopher:33/3S%09query', ref($url) . '->as_string'); $url->epath("45%09a"); is($url->gtype, '4', ref($url) . '->as_string'); is($url->selector, '5', ref($url) . '->as_string'); is($url->search, 'a', ref($url) . '->as_string'); is($url->string, undef, ref($url) . '->as_string'); is($url->path, "/45\ta", ref($url) . '->as_string'); # $url->path("00\t%09gisle"); # is($url->search '%09gisle', ref($url) . '->search'); # Let's test som other URL schemes $url = new URI::URL 'news:'; $url->group("comp.lang.perl.misc"); is($url->as_string, 'news:comp.lang.perl.misc', ref($url) . '->as_string'); $url->article('<1234@a.sn.no>'); is($url->as_string, 'news:1234@a.sn.no', ref($url) . '->as_string: "<" and ">" are gone'); # This one should be illegal eval { $url->article("no.perl"); }; die "This one should really complain" unless $@; # $url = new URI::URL 'mailto:'; # $url->user("aas"); # $url->host("a.sn.no"); # is($url->as_string, 'mailto:aas@a.sn.no', ref($url) . '->as_string'); # $url->address('foo@bar'); # is($url->host, 'bar', ref($url) . '->as_string'); # is($url->user, 'foo', ref($url) . '->as_string'); # $url = new URI::URL 'wais://host/database/wt/wpath'; # $url->database('foo'); # is($url->as_string, 'wais://host/foo/wt/wpath', ref($url) . '->as_string'); # $url->wtype('bar'); # is($url->as_string, 'wais://host/foo/bar/wpath', ref($url) . '->as_string'); # Test crack method for various URLs my(@crack, $crack); @crack = URI::URL->new("http://host/path;param?query#frag")->crack; is(scalar(@crack), 9, '9 elements'); $crack = join("", map { defined($_) ? $_ : "UNDEF" } @crack); note "Cracked result: $crack"; is($crack, "httpUNDEFUNDEFhost80/pathparamqueryfrag", 'crack result'); @crack = URI::URL->new("foo/bar", "ftp://aas\@ftp.sn.no/")->crack; is(scalar(@crack), 9, '9 elements'); $crack = join("", map { defined($_) ? $_ : "UNDEF" } @crack); note "Cracked result: $crack"; # die "Bad crack result" unless # $crack eq "ftpUNDEFUNDEFUNDEF21foo/barUNDEFUNDEFUNDEF"; @crack = URI::URL->new('ftp://u:p@host/q?path')->crack; is(scalar(@crack), 9, '9 elements'); $crack = join("", map { defined($_) ? $_ : "UNDEF" } @crack); note "Cracked result: $crack"; is($crack, "ftpuphost21/q?pathUNDEFpathUNDEF", 'crack result'); @crack = URI::URL->new("ftp://ftp.sn.no/pub")->crack; # Test anon ftp is(scalar(@crack), 9, '9 elements'); ok($crack[2], "passwd in anonymous crack"); $crack[2] = 'passwd'; # easier to test when we know what it is $crack = join("", map { defined($_) ? $_ : "UNDEF" } @crack); note "Cracked result: $crack"; is($crack, "ftpanonymouspasswdftp.sn.no21/pubUNDEFUNDEFUNDEF", 'crack result'); @crack = URI::URL->new('mailto:aas@sn.no')->crack; is(scalar(@crack), 9, '9 elements'); $crack = join("", map { defined($_) ? $_ : "UNDEF" } @crack); note "Cracked result: $crack"; # die "Bad crack result" unless # $crack eq "mailtoaasUNDEFsn.noUNDEFaas\@sn.noUNDEFUNDEFUNDEF"; @crack = URI::URL->new('news:comp.lang.perl.misc')->crack; is(scalar(@crack), 9, '9 elements'); $crack = join("", map { defined($_) ? $_ : "UNDEF" } @crack); note "Cracked result: $crack"; is($crack, "newsUNDEFUNDEFUNDEF119comp.lang.perl.miscUNDEFUNDEFUNDEF", 'crack result'); } # # netloc_test() # # Test automatic netloc synchronisation # sub netloc_test { my $url = new URI::URL 'ftp://anonymous:p%61ss@h�st:12345'; is($url->user, 'anonymous', ref($url) . '->as_string'); is($url->password, 'pass', ref($url) . '->as_string'); is($url->host, 'xn--hst-ula', ref($url) . '->as_string'); is($url->port, 12345, ref($url) . '->as_string'); # Can't really know how netloc is represented since it is partially escaped #is($url->netloc, 'anonymous:pass@hst:12345', ref($url) . '->as_string'); is($url->as_string, 'ftp://anonymous:pass@xn--hst-ula:12345', ref($url) . '->as_string'); # The '0' is sometimes tricky to get right $url->user(0); $url->password(0); $url->host(0); $url->port(0); is($url->netloc, '0:0@0:0', ref($url) . '->as_string'); $url->host(undef); is($url->netloc, '0:0@:0', ref($url) . '->as_string'); $url->host('h'); $url->user(undef); is($url->netloc, ':0@h:0', ref($url) . '->as_string'); $url->user(''); is($url->netloc, ':0@h:0', ref($url) . '->as_string'); $url->password(''); is($url->netloc, ':@h:0', ref($url) . '->as_string'); $url->user('foo'); is($url->netloc, 'foo:@h:0', ref($url) . '->as_string'); # Let's try a simple one $url->user('nemo'); $url->password('p2'); $url->host('hst2'); $url->port(2); is($url->netloc, 'nemo:p2@hst2:2', ref($url) . '->as_string'); $url->user(undef); $url->password(undef); $url->port(undef); is($url->netloc, 'hst2', ref($url) . '->as_string'); is($url->port, '21', ref($url) . '->as_string'); # the default ftp port $url->port(21); is($url->netloc, 'hst2:21', ref($url) . '->as_string'); # Let's try some reserved chars $url->user("@"); $url->password(":-#-;-/-?"); is($url->as_string, 'ftp://%40::-%23-;-%2F-%3F@hst2:21', ref($url) . '->as_string'); } # # port_test() # # Test port behaviour # sub port_test { $url = URI::URL->new('http://foo/root/dir/'); my $port = $url->port; is($port, 80, 'port'); is($url->as_string, 'http://foo/root/dir/', 'string'); $url->port(8001); $port = $url->port; is($port, 8001, 'port'); is($url->as_string, 'http://foo:8001/root/dir/', 'string'); $url->port(80); $port = $url->port; is($port, 80, 'port'); is($url->canonical->as_string, 'http://foo/root/dir/', 'string'); $url->port(8001); $url->port(undef); $port = $url->port; is($port, 80, 'port'); is($url->canonical->as_string, 'http://foo/root/dir/', 'string'); } ##################################################################### # # escape_test() # # escaping functions sub escape_test { # supply escaped URL $url = new URI::URL 'http://web/this%20has%20spaces'; # check component is unescaped is($url->path, '/this has spaces', ref($url) . '->as_string'); # modify the unescaped form $url->path('this ALSO has spaces'); # check whole url is escaped is($url->as_string, 'http://web/this%20ALSO%20has%20spaces', ref($url) . '->as_string'); $url = new URI::URL uri_escape('http://web/try %?#" those'); is($url->as_string, 'http%3A%2F%2Fweb%2Ftry%20%25%3F%23%22%20those', ref($url) . '->as_string'); my $all = pack('C',0..255); my $esc = uri_escape($all); my $new = uri_unescape($esc); is($all, $new, "uri_escape->uri_unescape"), $url->path($all); if ( URI::HAS_RESERVED_SQUARE_BRACKETS ) { # legacy: this was legal before '[' and ']' were restricted to the host part of the URI (see: RFC 3513 & RFC 3986) is($url->full_path, q(%00%01%02%03%04%05%06%07%08%09%0A%0B%0C%0D%0E%0F%10%11%12%13%14%15%16%17%18%19%1A%1B%1C%1D%1E%1F%20!%22%23$%&'()+,-./0123456789:;%3C=%3E%3F@ABCDEFGHIJKLMNOPQRSTUVWXYZ[%5C]%5E_%60abcdefghijklmnopqrstuvwxyz%7B%7C%7D~%7F%80%81%82%83%84%85%86%87%88%89%8A%8B%8C%8D%8E%8F%90%91%92%93%94%95%96%97%98%99%9A%9B%9C%9D%9E%9F%A0%A1%A2%A3%A4%A5%A6%A7%A8%A9%AA%AB%AC%AD%AE%AF%B0%B1%B2%B3%B4%B5%B6%B7%B8%B9%BA%BB%BC%BD%BE%BF%C0%C1%C2%C3%C4%C5%C6%C7%C8%C9%CA%CB%CC%CD%CE%CF%D0%D1%D2%D3%D4%D5%D6%D7%D8%D9%DA%DB%DC%DD%DE%DF%E0%E1%E2%E3%E4%E5%E6%E7%E8%E9%EA%EB%EC%ED%EE%EF%F0%F1%F2%F3%F4%F5%F6%F7%F8%F9%FA%FB%FC%FD%FE%FF), ref($url) . '->as_string'); } else { is($url->full_path, q(%00%01%02%03%04%05%06%07%08%09%0A%0B%0C%0D%0E%0F%10%11%12%13%14%15%16%17%18%19%1A%1B%1C%1D%1E%1F%20!%22%23$%&'()+,-./0123456789:;%3C=%3E%3F@ABCDEFGHIJKLMNOPQRSTUVWXYZ%5B%5C%5D%5E_%60abcdefghijklmnopqrstuvwxyz%7B%7C%7D~%7F%80%81%82%83%84%85%86%87%88%89%8A%8B%8C%8D%8E%8F%90%91%92%93%94%95%96%97%98%99%9A%9B%9C%9D%9E%9F%A0%A1%A2%A3%A4%A5%A6%A7%A8%A9%AA%AB%AC%AD%AE%AF%B0%B1%B2%B3%B4%B5%B6%B7%B8%B9%BA%BB%BC%BD%BE%BF%C0%C1%C2%C3%C4%C5%C6%C7%C8%C9%CA%CB%CC%CD%CE%CF%D0%D1%D2%D3%D4%D5%D6%D7%D8%D9%DA%DB%DC%DD%DE%DF%E0%E1%E2%E3%E4%E5%E6%E7%E8%E9%EA%EB%EC%ED%EE%EF%F0%F1%F2%F3%F4%F5%F6%F7%F8%F9%FA%FB%FC%FD%FE%FF), ref($url) . '->as_string'); } # test escaping uses uppercase (preferred by rfc1837) $url = new URI::URL 'file://h/'; $url->path(chr(0x7F)); is($url->as_string, 'file://h/%7F', ref($url) . '->as_string'); return; # reserved characters differ per scheme ## XXX is this '?' allowed to be unescaped $url = new URI::URL 'file://h/test?ing'; is($url->path, '/test?ing', ref($url) . '->as_string'); $url = new URI::URL 'file://h/'; $url->epath('question?mark'); is($url->as_string, 'file://h/question?mark', ref($url) . '->as_string'); # XXX Why should this be any different??? # Perhaps we should not expect too much :-) $url->path('question?mark'); is($url->as_string, 'file://h/question%3Fmark', ref($url) . '->as_string'); # See what happens when set different elements to this ugly sting my $reserved = ';/?:@&=#%'; $url->path($reserved . "foo"); is($url->as_string, 'file://h/%3B/%3F%3A%40%26%3D%23%25foo', ref($url) . '->as_string'); $url->scheme('http'); $url->path(''); is($url->as_string, 'http://h/', ref($url) . '->as_string'); $url->query($reserved); $url->params($reserved); $url->frag($reserved); is($url->as_string, 'http://h/;%3B%2F%3F%3A%40&=%23%25?%3B%2F%3F%3A%40&=%23%25#;/?:@&=#%', ref($url) . '->as_string'); my $str = $url->as_string; $url = new URI::URL $str; die "URL changed" if $str ne $url->as_string; $url = new URI::URL 'ftp:foo'; $url->user($reserved); $url->host($reserved); is($url->as_string, 'ftp://%3B%2F%3F%3A%40%26%3D%23%25@%3B%2F%3F%3A%40%26%3D%23%25/foo', ref($url) . '->as_string'); } ##################################################################### # # newlocal_test() # sub newlocal_test { return 1 if $^O eq "MacOS"; my $isMSWin32 = ($^O =~ /MSWin32/i); my $pwd = ($isMSWin32 ? 'cd' : ($^O eq 'qnx' ? '/usr/bin/fullpath -t' : ($^O eq 'VMS' ? 'show default' : (-e '/bin/pwd' ? '/bin/pwd' : 'pwd')))); my $tmpdir = tempdir(); if ( $^O eq 'qnx' ) { $tmpdir = `/usr/bin/fullpath -t $tmpdir`; chomp $tmpdir; } $tmpdir = '/sys$scratch' if $^O eq 'VMS'; $tmpdir =~ tr\|\\\|/\|; my $savedir = `$pwd`; # we don't use Cwd.pm because we want to check # that it get require'd correctly by URL.pm chomp $savedir; if ($^O eq 'VMS') { $savedir =~ s#^\s+##; $savedir = VMS::Filespec::unixpath($savedir); $savedir =~ s#/$##; } # cwd chdir($tmpdir) or die $!; my $dir = `$pwd`; $dir =~ tr\|\\\|/\|; chomp $dir; if ($^O eq 'VMS') { $dir =~ s#^\s+##; $dir = VMS::Filespec::unixpath($dir); $dir =~ s#/$##; } $dir = uri_escape($dir, ':'); $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32 or $^O eq 'os2'; $url = newlocal URI::URL; my $ss = $isMSWin32 ? '//' : (($dir =~ m,^/,) ? '' : '///' ); is($url->as_string, URI::URL->new("file:$ss$dir/")->as_string, ref($url) . '->as_string'); note "Local directory is ". $url->local_path . "\n"; if ($^O ne 'VMS') { # absolute dir chdir('/') or die $!; $url = newlocal URI::URL '/usr/'; is($url->as_string, 'file:/usr/', ref($url) . '->as_string'); # absolute file $url = newlocal URI::URL '/vmunix'; is($url->as_string, 'file:/vmunix', ref($url) . '->as_string'); } # relative file chdir($tmpdir) or fail $!; $dir = `$pwd`; $dir =~ tr\|\\\|/\|; chomp $dir; if ($^O eq 'VMS') { $dir =~ s#^\s+##; $dir = VMS::Filespec::unixpath($dir); $dir =~ s#/$##; } $dir = uri_escape($dir, ':'); $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32 or $^O eq 'os2'; $url = newlocal URI::URL 'foo'; is($url->as_string, "file:$ss$dir/foo", ref($url) . '->as_string'); # relative dir chdir($tmpdir) or fail $!; $dir = `$pwd`; $dir =~ tr\|\\\|/\|; chomp $dir; if ($^O eq 'VMS') { $dir =~ s#^\s+##; $dir = VMS::Filespec::unixpath($dir); $dir =~ s#/$##; } $dir = uri_escape($dir, ':'); $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32 or $^O eq 'os2'; $url = newlocal URI::URL 'bar/'; is($url->as_string, "file:$ss$dir/bar/", ref($url) . '->as_string'); # 0 if ($^O ne 'VMS') { chdir('/') or fail $!; $dir = `$pwd`; $dir =~ tr\|\\\|/\|; chomp $dir; $dir = uri_escape($dir, ':'); $dir =~ s/^(\w)%3A/$1:/ if $isMSWin32 or $^O eq 'os2'; $url = newlocal URI::URL '0'; is($url->as_string, "file:$ss${dir}0", ref($url) . '->as_string'); } # Test access methods for file URLs $url = new URI::URL 'file:/c:/dos'; is($url->dos_path, 'C:\\DOS', ref($url) . '->as_string'); is($url->unix_path, '/c:/dos', ref($url) . '->as_string'); #is($url->vms_path, '[C:]DOS', ref($url) . '->as_string'); is($url->mac_path, undef, ref($url) . '->as_string'); $url = new URI::URL 'file:/foo/bar'; is($url->unix_path, '/foo/bar', ref($url) . '->as_string'); is($url->mac_path, 'foo:bar', ref($url) . '->as_string'); # Some edge cases # $url = new URI::URL 'file:'; # is($url->unix_path, '/', ref($url) . '->as_string'); $url = new URI::URL 'file:/'; is($url->unix_path, '/', ref($url) . '->as_string'); $url = new URI::URL 'file:.'; is($url->unix_path, '.', ref($url) . '->as_string'); $url = new URI::URL 'file:./foo'; is($url->unix_path, './foo', ref($url) . '->as_string'); $url = new URI::URL 'file:0'; is($url->unix_path, '0', ref($url) . '->as_string'); $url = new URI::URL 'file:../../foo'; is($url->unix_path, '../../foo', ref($url) . '->as_string'); $url = new URI::URL 'file:foo/../bar'; is($url->unix_path, 'foo/../bar', ref($url) . '->as_string'); # Relative files $url = new URI::URL 'file:foo/b%61r/Note.txt'; is($url->unix_path, 'foo/bar/Note.txt', ref($url) . '->as_string'); is($url->mac_path, ':foo:bar:Note.txt', ref($url) . '->as_string'); is($url->dos_path, 'FOO\\BAR\\NOTE.TXT', ref($url) . '->as_string'); #is($url->vms_path', '[.FOO.BAR]NOTE.TXT', ref($url) . '->as_string'); # The VMS path found in RFC 1738 (section 3.10) $url = new URI::URL 'file://vms.host.edu/disk$user/my/notes/note12345.txt'; # is($url->vms_path, 'DISK$USER:[MY.NOTES]NOTE12345.TXT', ref($url) . '->as_string'); # is($url->mac_path, 'disk$user:my:notes:note12345.txt', ref($url) . '->as_string'); chdir($savedir) or fail $!; } ##################################################################### # # absolute_test() # sub absolute_test { # Tests from draft-ietf-uri-relative-url-06.txt # Copied verbatim from the draft, parsed below @URI::URL::g::ISA = qw(URI::URL::_generic); # for these tests my $base = 'http://a/b/c/d;p?q#f'; my $absolute_tests = <<EOM; 5.1. Normal Examples g:h = <URL:g:h> g = <URL:http://a/b/c/g> ./g = <URL:http://a/b/c/g> g/ = <URL:http://a/b/c/g/> /g = <URL:http://a/g> //g = <URL:http://g> # ?y = <URL:http://a/b/c/d;p?y> g?y = <URL:http://a/b/c/g?y> g?y/./x = <URL:http://a/b/c/g?y/./x> #s = <URL:http://a/b/c/d;p?q#s> g#s = <URL:http://a/b/c/g#s> g#s/./x = <URL:http://a/b/c/g#s/./x> g?y#s = <URL:http://a/b/c/g?y#s> # ;x = <URL:http://a/b/c/d;x> g;x = <URL:http://a/b/c/g;x> g;x?y#s = <URL:http://a/b/c/g;x?y#s> . = <URL:http://a/b/c/> ./ = <URL:http://a/b/c/> .. = <URL:http://a/b/> ../ = <URL:http://a/b/> ../g = <URL:http://a/b/g> ../.. = <URL:http://a/> ../../ = <URL:http://a/> ../../g = <URL:http://a/g> 5.2. Abnormal Examples Although the following abnormal examples are unlikely to occur in normal practice, all URL parsers should be capable of resolving them consistently. Each example uses the same base as above. An empty reference resolves to the complete base URL: <> = <URL:http://a/b/c/d;p?q#f> Parsers must be careful in handling the case where there are more relative path ".." segments than there are hierarchical levels in the base URL's path. Note that the ".." syntax cannot be used to change the <net_loc> of a URL. ../../../g = <URL:http://a/../g> ../../../../g = <URL:http://a/../../g> Similarly, parsers must avoid treating "." and ".." as special when they are not complete components of a relative path. /./g = <URL:http://a/./g> /../g = <URL:http://a/../g> g. = <URL:http://a/b/c/g.> .g = <URL:http://a/b/c/.g> g.. = <URL:http://a/b/c/g..> ..g = <URL:http://a/b/c/..g> Less likely are cases where the relative URL uses unnecessary or nonsensical forms of the "." and ".." complete path segments. ./../g = <URL:http://a/b/g> ./g/. = <URL:http://a/b/c/g/> g/./h = <URL:http://a/b/c/g/h> g/../h = <URL:http://a/b/c/h> Finally, some older parsers allow the scheme name to be present in a relative URL if it is the same as the base URL scheme. This is considered to be a loophole in prior specifications of partial URLs [1] and should be avoided by future parsers. http:g = <URL:http:g> http: = <URL:http:> EOM # convert text to list like # @absolute_tests = ( ['g:h' => 'g:h'], ...) my @absolute_tests; for my $line (split("\n", $absolute_tests)) { next unless $line =~ /^\s{6}/; if ($line =~ /^\s+(\S+)\s=\s<URL:([^>])>/) { my($rel, $abs) = ($1, $2); $rel = '' if $rel eq '<>'; push(@absolute_tests, [$rel, $abs]); } else { warn "illegal line '$line'"; } } # add some extra ones for good measure push(@absolute_tests, ['x/y//../z' => 'http://a/b/c/x/y/z'], ['1' => 'http://a/b/c/1' ], ['0' => 'http://a/b/c/0' ], ['/0' => 'http://a/0' ], # ['%2e/a' => 'http://a/b/c/%2e/a'], # %2e is '.' # ['%2e%2e/a' => 'http://a/b/c/%2e%2e/a'], ); note " Relative + Base => Expected Absolute URL"; note "------------------------------------------------\n"; for my $test (@absolute_tests) { my($rel, $abs) = @$test; my $abs_url = new URI::URL $abs; my $abs_str = $abs_url->as_string; note sprintf(" %-10s + $base => %s", $rel, $abs); my $u = new URI::URL $rel, $base; my $got = $u->abs; is($got->as_string, $abs_str, ref($url) . '->as_string'); } # bug found and fixed in 1.9 by "J.E. Fritz" <FRITZ@gems.vcu.edu> $base = new URI::URL 'http://host/directory/file'; my $relative = new URI::URL 'file', $base; my $result = $relative->abs; my ($a, $b) = ($base->path, $result->path); is($a, $b, 'identity'); # Counter the expectation of least surprise, # section 6 of the draft says the URL should # be canonicalised, rather than making a simple # substitution of the last component. # Better doublecheck someone hasn't "fixed this bug" :-) $base = new URI::URL 'http://host/dir1/../dir2/file'; $relative = new URI::URL 'file', $base; $result = $relative->abs; is($result, 'http://host/dir2/file', 'URL canonicalised'); note "--------"; # Test various other kinds of URLs and how they like to be absolutized for (["http://abc/", "news:45664545", "http://abc/"], ["news:abc", "http://abc/", "news:abc"], ["abc", "file:/test?aas", "file:/abc"], # ["gopher:", "", "gopher:"], # ["?foo", "http://abc/a", "http://abc/a?foo"], ["?foo", "file:/abc", "file:/abc?foo"], ["#foo", "http://abc/a", "http://abc/a#foo"], ["#foo", "file:a", "file:a#foo"], ["#foo", "file:/a", "file:/a#foo"], ["#foo", "file:/a", "file:/a#foo"], ["#foo", "file://localhost/a", "file://localhost/a#foo"], ['123@sn.no', "news:comp.lang.perl.misc", 'news:/123@sn.no'], ['no.perl', 'news:123@sn.no', 'news:/no.perl'], ['mailto:aas@a.sn.no', "http://www.sn.no/", 'mailto:aas@a.sn.no'], # Test absolutizing with old behaviour. ['http:foo', 'http://h/a/b', 'http://h/a/foo'], ['http:/foo', 'http://h/a/b', 'http://h/foo'], ['http:?foo', 'http://h/a/b', 'http://h/a/b?foo'], ['http:#foo', 'http://h/a/b', 'http://h/a/b#foo'], ['http:?foo#bar','http://h/a/b', 'http://h/a/b?foo#bar'], ['file:/foo', 'http://h/a/b', 'file:/foo'], ) { my($url, $base, $expected_abs) = @$_; my $rel = new URI::URL $url, $base; my $abs = $rel->abs($base, 1); note sprintf(" %-12s+ $base => %s", $rel, $abs); is($abs->as_string, $expected_abs, ref($url) . '->as_string'); } note "absolute test ok\n"; # Test relative function for ( ["http://abc/a", "http://abc", "a"], ["http://abc/a", "http://abc/b", "a"], ["http://abc/a?q", "http://abc/b", "a?q"], ["http://abc/a;p", "http://abc/b", "a;p"], ["http://abc/a", "http://abc/a/b/c/", "../../../a"], ["http://abc/a/", "http://abc/a/", "./"], ["http://abc/a#f", "http://abc/a", "#f"], ["file:/etc/motd", "file:/", "etc/motd"], ["file:/etc/motd", "file:/etc/passwd", "motd"], ["file:/etc/motd", "file:/etc/rc2.d/", "../motd"], ["file:/etc/motd", "file:/usr/lib/doc", "../../etc/motd"], ["file:", "file:/etc/", "../"], ["file:foo", "file:/etc/", "../foo"], ["mailto:aas", "http://abc", "mailto:aas"], # Nicolai Langfeldt's original example ["http://www.math.uio.no/doc/mail/top.html", "http://www.math.uio.no/doc/linux/", "../mail/top.html"], ) { my($abs, $base, $expect) = @$_; my $rel = URI::URL->new($abs, $base)->rel; is($rel->as_string, $expect, "url('$abs', '$base')->rel = '$expect'"); } note "relative test ok\n"; } sub eq_test { my $u1 = new URI::URL 'http://abc.com:80/~smith/home.html'; my $u2 = new URI::URL 'http://ABC.com/%7Esmith/home.html'; my $u3 = new URI::URL 'http://ABC.com:/%7esmith/home.html'; # Test all permutations of these tree ok($u1->eq($u2), "1: $u1 ne $u2"); ok($u1->eq($u3), "2: $u1 ne $u3"); ok($u2->eq($u1), "3: $u2 ne $u1"); ok($u2->eq($u3), "4: $u2 ne $u3"); ok($u3->eq($u1), "5: $u3 ne $u1"); ok($u3->eq($u2), "6: $u3 ne $u2"); # Test empty path my $u4 = new URI::URL 'http://www.sn.no'; ok($u4->eq("HTTP://WWW.SN.NO:80/"), "7: $u4"); ok(!$u4->eq("http://www.sn.no:81"),"8: $u4"); # Test mailto # my $u5 = new URI::URL 'mailto:AAS@SN.no'; # ok($u5->eq('mailto:aas@sn.no'), "9: $u5"); # Test reserved char my $u6 = new URI::URL 'ftp://ftp/%2Fetc'; ok($u6->eq("ftp://ftp/%2fetc"), "10: $u6"); ok(!$u6->eq("ftp://ftp://etc"), "11: $u6"); } ��roytest1.html��0000644��00000016505�15125162450�0007234 0��ustar�00��<HTML><HEAD> <TITLE>Examples of Resolving Relative URLs</TITLE> <BASE href="http://a/b/c/d;p?q"> </HEAD><BODY> <H1>Examples of Resolving Relative URLs</H1> This document has an embedded base URL of <PRE> Content-Base: http://a/b/c/d;p?q </PRE> the relative URLs should be resolved as shown below. <P> I will need your help testing the examples on multiple browsers. What you need to do is point to the example anchor and compare it to the resolved URL in your browser (most browsers have a feature by which you can see the resolved URL at the bottom of the window/screen when the anchor is active). <H2>Tested Clients and Client Libraries</H2> <DL COMPACT> <DT>[R] <DD>RFC 2396 (the right way to parse) <DT>[X] <DD>RFC 1808 <DT>[1] <DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav) <DT>[2] <DD>Lynx/2.7.1 libwww-FM/2.14 <DT>[3] <DD>MSIE 3.01; Windows 95 <DT>[4] <DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) libwww/2.12 <DT>[5] <DD>libwww-perl/5.14 [Martijn Koster] </DL> <H2>Normal Examples</H2> <PRE> RESULTS from <a href="g:h">g:h</a> = g:h [R,X,2,3,4,5] http://a/b/c/g:h [1] <a href="g">g</a> = http://a/b/c/g [R,X,1,2,3,4,5] <a href="./g">./g</a> = http://a/b/c/g [R,X,1,2,3,4,5] <a href="g/">g/</a> = http://a/b/c/g/ [R,X,1,2,3,4,5] <a href="/g">/g</a> = http://a/g [R,X,1,2,3,4,5] <a href="//g">//g</a> = http://g [R,X,1,2,3,4,5] <a href="?y">?y</a> = http://a/b/c/?y [R,1,2,3,4] http://a/b/c/d;p?y [X,5] <a href="g?y">g?y</a> = http://a/b/c/g?y [R,X,1,2,3,4,5] <a name="s" href="#s">#s</a> = (current document)#s [R,2,4] http://a/b/c/d;p?q#s [X,1,3,5] <a href="g#s">g#s</a> = http://a/b/c/g#s [R,X,1,2,3,4,5] <a href="g?y#s">g?y#s</a> = http://a/b/c/g?y#s [R,X,1,2,3,4,5] <a href=";x">;x</a> = http://a/b/c/;x [R,1,2,3,4] http://a/b/c/d;x [X,5] <a href="g;x">g;x</a> = http://a/b/c/g;x [R,X,1,2,3,4,5] <a href="g;x?y#s">g;x?y#s</a> = http://a/b/c/g;x?y#s [R,X,1,2,3,4,5] <a href=".">.</a> = http://a/b/c/ [R,X,2,5] http://a/b/c/. [1] http://a/b/c [3,4] <a href="./">./</a> = http://a/b/c/ [R,X,1,2,3,4,5] <a href="..">..</a> = http://a/b/ [R,X,2,5] http://a/b [1,3,4] <a href="../">../</a> = http://a/b/ [R,X,1,2,3,4,5] <a href="../g">../g</a> = http://a/b/g [R,X,1,2,3,4,5] <a href="../..">../..</a> = http://a/ [R,X,2,5] http://a [1,3,4] <a href="../../">../../</a> = http://a/ [R,X,1,2,3,4,5] <a href="../../g">../../g</a> = http://a/g [R,X,1,2,3,4,5] </PRE> <H2>Abnormal Examples</H2> Although the following abnormal examples are unlikely to occur in normal practice, all URL parsers should be capable of resolving them consistently. Each example uses the same base as above.<P> An empty reference refers to the start of the current document. <PRE> <a href=""><></a> = (current document) [R,2,4] http://a/b/c/d;p?q [X,3,5] http://a/b/c/ [1] </PRE> Parsers must be careful in handling the case where there are more relative path ".." segments than there are hierarchical levels in the base URL's path. Note that the ".." syntax cannot be used to change the site component of a URL. <PRE> <a href="../../../g">../../../g</a> = http://a/../g [R,X,2,4,5] http://a/g [R,1,3] <a href="../../../../g">../../../../g</a> = http://a/../../g [R,X,2,4,5] http://a/g [R,1,3] </PRE> In practice, some implementations strip leading relative symbolic elements (".", "..") after applying a relative URL calculation, based on the theory that compensating for obvious author errors is better than allowing the request to fail. Thus, the above two references will be interpreted as "http://a/g" by some implementations. <P> Similarly, parsers must avoid treating "." and ".." as special when they are not complete components of a relative path. <PRE> <a href="/./g">/./g</a> = http://a/./g [R,X,2,3,4,5] http://a/g [1] <a href="/../g">/../g</a> = http://a/../g [R,X,2,3,4,5] http://a/g [1] <a href="g.">g.</a> = http://a/b/c/g. [R,X,1,2,3,4,5] <a href=".g">.g</a> = http://a/b/c/.g [R,X,1,2,3,4,5] <a href="g..">g..</a> = http://a/b/c/g.. [R,X,1,2,3,4,5] <a href="..g">..g</a> = http://a/b/c/..g [R,X,1,2,3,4,5] </PRE> Less likely are cases where the relative URL uses unnecessary or nonsensical forms of the "." and ".." complete path segments. <PRE> <a href="./../g">./../g</a> = http://a/b/g [R,X,1,2,5] http://a/b/c/../g [3,4] <a href="./g/.">./g/.</a> = http://a/b/c/g/ [R,X,2,5] http://a/b/c/g/. [1] http://a/b/c/g [3,4] <a href="g/./h">g/./h</a> = http://a/b/c/g/h [R,X,1,2,3,4,5] <a href="g/../h">g/../h</a> = http://a/b/c/h [R,X,1,2,3,4,5] <a href="g;x=1/./y">g;x=1/./y</a> = http://a/b/c/g;x=1/y [R,1,2,3,4] http://a/b/c/g;x=1/./y [X,5] <a href="g;x=1/../y">g;x=1/../y</a> = http://a/b/c/y [R,1,2,3,4] http://a/b/c/g;x=1/../y [X,5] </PRE> All client applications remove the query component from the base URL before resolving relative URLs. However, some applications fail to separate the reference's query and/or fragment components from a relative path before merging it with the base path. This error is rarely noticed, since typical usage of a fragment never includes the hierarchy ("/") character, and the query component is not normally used within relative references. <PRE> <a href="g?y/./x">g?y/./x</a> = http://a/b/c/g?y/./x [R,X,5] http://a/b/c/g?y/x [1,2,3,4] <a href="g?y/../x">g?y/../x</a> = http://a/b/c/g?y/../x [R,X,5] http://a/b/c/x [1,2,3,4] <a href="g#s/./x">g#s/./x</a> = http://a/b/c/g#s/./x [R,X,2,3,4,5] http://a/b/c/g#s/x [1] <a href="g#s/../x">g#s/../x</a> = http://a/b/c/g#s/../x [R,X,2,3,4,5] http://a/b/c/x [1] </PRE> Some parsers allow the scheme name to be present in a relative URI if it is the same as the base URI scheme. This is considered to be a loophole in prior specifications of partial URI [RFC1630]. Its use should be avoided. <PRE> <a href="http:g">http:g</a> = http:g [R,X,5] \| http://a/b/c/g [1,2,3,4] (ok for compat.) <a href="http:">http:</a> = http: [R,X,5] http://a/b/c/ [1] http://a/b/c/d;p?q [2,3,4] </PRE> </BODY></HTML> ��path-segments.t��0000644��00000001750�15125162450�0007514 0��ustar�00��use strict; use warnings; use Test::More 'no_plan'; use URI (); { my $u = URI->new("http://www.example.org/a/b/c"); is_deeply [$u->path_segments], ['', qw(a b c)], 'path_segments in list context'; is $u->path_segments, '/a/b/c', 'path_segments in scalar context'; is_deeply [$u->path_segments('', qw(z y x))], ['', qw(a b c)], 'set path_segments in list context'; is $u->path_segments('/i/j/k'), '/z/y/x', 'set path_segments in scalar context'; $u->path_segments('', qw(q r s)); is $u->path_segments, '/q/r/s', 'set path_segments in void context'; } { my $u = URI->new("http://www.example.org/abc"); $u->path_segments('', '%', ';', '/'); is $u->path_segments, '/%25/%3B/%2F', 'escaping special characters'; } { my $u = URI->new("http://www.example.org/abc;param1;param2"); my @ps = $u->path_segments; isa_ok $ps[1], 'URI::_segment'; $u->path_segments(@ps); is $u->path_segments, '/abc;param1;param2', 'dealing with URI segments'; } ��ftp.t��0000644��00000001367�15125162450�0005532 0��ustar�00��use strict; use warnings; use Test::More tests => 13; use URI (); my $uri; $uri = URI->new("ftp://ftp.example.com/path"); is($uri->scheme, "ftp"); is($uri->host, "ftp.example.com"); is($uri->port, 21); is($uri->user, "anonymous"); is($uri->password, 'anonymous@'); $uri->userinfo("gisle\@aas.no"); is($uri, "ftp://gisle%40aas.no\@ftp.example.com/path"); is($uri->user, "gisle\@aas.no"); is($uri->password, undef); $uri->password("secret"); is($uri, "ftp://gisle%40aas.no:secret\@ftp.example.com/path"); $uri = URI->new("ftp://gisle\@aas.no:secret\@ftp.example.com/path"); is($uri, "ftp://gisle\@aas.no:secret\@ftp.example.com/path"); is($uri->userinfo, "gisle\@aas.no:secret"); is($uri->user, "gisle\@aas.no"); is($uri->password, "secret"); ��escape.t��0000644��00000005612�15125162450�0006176 0��ustar�00��use strict; use warnings; use Test::More; use Test::Warnings qw( :all ); use Test::Fatal; use URI::Escape qw( %escapes uri_escape uri_escape_utf8 uri_unescape ); is uri_escape("\|abc�"), "%7Cabc%E5"; is uri_escape("abc", "b-d"), "a%62%63"; # New escapes in RFC 3986 is uri_escape("~'()"), "~%2A%27%28%29"; is uri_escape("<\">"), "%3C%22%3E"; is uri_escape(undef), undef; is uri_unescape("%7Cabc%e5"), "\|abc�"; is_deeply [uri_unescape("%40A%42", "CDE", "F%47H")], [qw(@AB CDE FGH)]; is uri_escape ('/', '/'), '%2F', 'it should accept slash in unwanted characters', ; is uri_escape ('][', ']['), '%5D%5B', 'it should accept regex char group terminator in unwanted characters', ; is uri_escape ('[]\\', '][\\'), '%5B%5D%5C', 'it should accept regex escape character at the end of unwanted characters', ; is uri_escape ('[]\\${}', '][\\${`kill -0 -1`}'), '%5B%5D\\%24%7B%7D', 'it should recognize scalar interpolation injection in unwanted characters', ; is uri_escape ('[]\\@{}', '][\\@{`kill -0 -1`}'), '%5B%5D\\%40%7B%7D', 'it should recognize array interpolation injection in unwanted characters', ; is uri_escape ('[]\\%{}', '][\\%{`kill -0 -1`}'), '%5B%5D\\%25%7B%7D', 'it should recognize hash interpolation injection in unwanted characters', ; is uri_escape ('a-b', '-bc'), 'a%2D%62', 'it should recognize leading minus', ; is uri_escape ('a-b', '^-bc'), '%61-b', 'it should recognize leading ^-' ; is uri_escape ('a-b-1', '[:alpha:][:digit:]'), '%61-%62-%31', 'it should recognize character groups' ; is uri_escape ('abcd-', '\w'), '%61%62%63%64-', 'it should allow character class escapes' ; is uri_escape ('a/b`]c^', '/-^'), 'a%2Fb`%5Dc%5E', 'regex characters like / and ^ allowed in range' ; like exception { uri_escape ('abcdef', 'd-c') }, qr/Invalid \[\] range "d-c" in regex/, 'invalid range with max less than min throws exception'; like join('', warnings { is uri_escape ('abcdeQE', '\Qabc\E'), '%61%62%63de%51%45', 'it should allow character class escapes' ; }), qr{ (?-x:Unrecognized escape \\Q in character class passed through in regex) . (?-x:Unrecognized escape \\E in character class passed through in regex) }xs, 'bad escapes emit warnings'; is uri_escape ('abcd-[]', qr/[bc]/), 'a%62%63d-[]', 'allows regexp objects', ; is uri_escape ('a12b21c12d', qr/12/), 'a%31%32b21c%31%32d', 'allows regexp objects matching multiple characters', ; is $escapes{"%"}, "%25"; is uri_escape_utf8("\|abc�"), "%7Cabc%C3%A5"; skip "Perl 5.8.0 or higher required", 3 if $] < 5.008; ok !eval { print uri_escape("abc" . chr(300)); 1 }; like $@, qr/^Can\'t escape \\x\{012C\}, try uri_escape_utf8\(\) instead/; is uri_escape_utf8(chr(0xFFF)), "%E0%BF%BF"; done_testing; ��idna.t��0000644��00000000767�15125162450�0005657 0��ustar�00��use strict; use warnings; use utf8; use Test::More tests => 7; use URI::_idna (); is URI::_idna::encode("www.example.com"), "www.example.com"; is URI::_idna::decode("www.example.com"), "www.example.com"; is URI::_idna::encode("www.example.com."), "www.example.com."; is URI::_idna::decode("www.example.com."), "www.example.com."; is URI::_idna::encode("Bücher.ch"), "xn--bcher-kva.ch"; is URI::_idna::decode("xn--bcher-kva.ch"), "bücher.ch"; is URI::_idna::decode("xn--bcher-KVA.ch"), "bücher.ch"; ��urn-isbn.t��0000644��00000001352�15125162450�0006470 0��ustar�00��use strict; use warnings; use Test::Needs { 'Business::ISBN' => 3.005 }; use Test::More tests => 13; use URI (); my $u = URI->new("URN:ISBN:0395363411"); ok($u eq "URN:ISBN:0395363411" && $u->scheme eq "urn" && $u->nid eq "isbn"); is($u->canonical, "urn:isbn:0-395-36341-1"); is($u->isbn, "0-395-36341-1"); is($u->isbn_group_code, 0); is($u->isbn_publisher_code, 395); is($u->isbn13, "9780395363416"); is($u->nss, "0395363411"); is($u->isbn("0-88730-866-x"), "0-395-36341-1"); is($u->nss, "0-88730-866-x"); is($u->isbn, "0-88730-866-X"); ok(URI::eq("urn:isbn:088730866x", "URN:ISBN:0-88-73-08-66-X")); # try to illegal ones $u = URI->new("urn:ISBN:abc"); is($u, "urn:ISBN:abc"); ok($u->nss eq "abc" && !defined $u->isbn); ��urn-scheme-exceptions.t��0000644��00000001015�15125162450�0011154 0��ustar�00��use strict; use warnings; use Test::More; use URI::urn; plan tests => 6; { require URI::_foreign; # load this before disabling @INC my $count = 0; local @INC = sub { $count++; return }; for ( 0 .. 1 ) { my $uri = URI->new('urn:asdfasdf:1.2.3.4.5.6.7.8.9.10'); is( $count, 1, 'only attempt to load the scheme package once' ); is( $@, '', 'no exception when trying to load a scheme handler class' ); ok( $uri->isa('URI'), 'but URI still instantiated as foreign' ); } } ��gopher.t��0000644��00000001774�15125162450�0006227 0��ustar�00��use strict; use warnings; use Test::More tests => 48; use URI (); sub check_gopher_uri { my ($u, $exphost, $expport, $exptype, $expselector, $expsearch) = @_; is("gopher", $u->scheme); is($exphost, $u->host); is($expport, $u->port); is($exptype, $u->gopher_type); is($expselector, $u->selector); is($expsearch, $u->search); } my $u; $u = URI->new("gopher://host"); check_gopher_uri($u, "host", 70, 1); $u = URI->new("gopher://host:70"); check_gopher_uri($u, "host", 70, 1); $u = URI->new("gopher://host:70/"); check_gopher_uri($u, "host", 70, 1); $u = URI->new("gopher://host:70/1"); check_gopher_uri($u, "host", 70, 1); $u = URI->new("gopher://host:70/1"); check_gopher_uri($u, "host", 70, 1); $u = URI->new("gopher://host:123/7foo"); check_gopher_uri($u, "host", 123, 7, "foo"); $u = URI->new("gopher://host/7foo\tbar%20baz"); check_gopher_uri($u, "host", 70, 7, "foo", "bar baz"); $u = URI->new("gopher://host/7foo%09bar%20baz"); check_gopher_uri($u, "host", 70, 7, "foo", "bar baz"); ��scheme-exceptions.t��0000644��00000000740�15125162450�0010356 0��ustar�00��use strict; use warnings; use Test::More; use URI (); require URI::_foreign; # load this before disabling @INC my $count = 0; local @INC = (sub { ++$count; return }); for (0 .. 1) { my $uri = URI->new('notreal://foo/bar'); is($count, 1, 'only attempt to load the scheme package once'); is($@, '', 'no exception when trying to load a scheme handler class'); ok($uri->isa('URI'), 'but URI still instantiated as foreign'); diag $count; } done_testing; ��clone.t��0000644��00000000513�15125162450�0006031 0��ustar�00��use strict; use warnings; use Test::More tests => 2; use URI::URL (); my $b = URI::URL->new("http://www/"); my $u1 = URI::URL->new("foo", $b); my $u2 = $u1->clone; $u1->base("http://yyy/"); #use Data::Dump; Data::Dump::dump($b, $u1, $u2); is $u1->abs->as_string, "http://yyy/foo"; is $u2->abs->as_string, "http://www/foo"; ��rel.t��0000644��00000001035�15125162450�0005513 0��ustar�00��use strict; use warnings; use Test::More; plan tests => 6; use URI (); my $uri; $uri = URI->new("http://www.example.com/foo/bar/"); is($uri->rel("http://www.example.com/foo/bar/"), "./"); is($uri->rel("HTTP://WWW.EXAMPLE.COM/foo/bar/"), "./"); is($uri->rel("HTTP://WWW.EXAMPLE.COM/FOO/BAR/"), "../../foo/bar/"); is($uri->rel("HTTP://WWW.EXAMPLE.COM:80/foo/bar/"), "./"); $uri = URI->new("http://www.example.com/foo/bar"); is($uri->rel("http://www.example.com/foo/bar"), "bar"); is($uri->rel("http://www.example.com/foo"), "foo/bar"); ��rsync.t��0000644��00000000407�15125162450�0006071 0��ustar�00��use strict; use warnings; use Test::More tests => 4; use URI (); my $u = URI->new('rsync://gisle@example.com/foo/bar'); is($u->user, "gisle"); is($u->port, 873); is($u->path, "/foo/bar"); $u->port(8730); is($u, 'rsync://gisle@example.com:8730/foo/bar'); ��sip.t��0000644��00000004353�15125162450�0005532 0��ustar�00��use strict; use warnings; use Test::More tests => 13; use URI (); my $u = URI->new('sip:phone@domain.ext'); ok($u->user eq 'phone' && $u->host eq 'domain.ext' && $u->port eq '5060' && $u->host_port eq 'domain.ext:5060' && $u->authority eq 'phone@domain.ext' && $u eq 'sip:phone@domain.ext'); $u->host_port('otherdomain.int:9999'); ok($u->host eq 'otherdomain.int' && $u->port eq '9999' && $u->host_port eq 'otherdomain.int:9999' && $u->authority eq 'phone@otherdomain.int:9999' && $u eq 'sip:phone@otherdomain.int:9999'); $u->port('5060'); $u = $u->canonical; ok($u->port eq '5060' && $u->host_port eq 'otherdomain.int:5060' && $u->authority eq 'phone@otherdomain.int' && $u eq 'sip:phone@otherdomain.int'); $u->user('voicemail'); ok($u->user eq 'voicemail' && $u->authority eq 'voicemail@otherdomain.int' && $u eq 'sip:voicemail@otherdomain.int'); $u->authority('fax@gateway.ext'); ok($u->user eq 'fax' && $u->host eq 'gateway.ext' && $u->host_port eq 'gateway.ext:5060' && $u->authority eq 'fax@gateway.ext' && $u eq 'sip:fax@gateway.ext'); $u = URI->new('sip:phone@domain.ext?Subject=Meeting&Priority=Urgent'); ok($u->query eq 'Subject=Meeting&Priority=Urgent'); $u->query_form(Subject => 'Lunch', Priority => 'Low'); my @q = $u->query_form; ok($u->query eq 'Subject=Lunch&Priority=Low' && @q == 4 && "@q" eq 'Subject Lunch Priority Low' && $u eq 'sip:phone@domain.ext?Subject=Lunch&Priority=Low'); $u = URI->new('sip:phone@domain.ext;maddr=127.0.0.1;ttl=16'); ok($u->params eq 'maddr=127.0.0.1;ttl=16'); $u->params('maddr=127.0.0.1;ttl=16;x-addedparam=1'); ok($u->params eq 'maddr=127.0.0.1;ttl=16;x-addedparam=1' && $u eq 'sip:phone@domain.ext;maddr=127.0.0.1;ttl=16;x-addedparam=1'); $u = URI->new('sip:phone@domain.ext?Subject=Meeting&Priority=Urgent'); $u->params_form(maddr => '127.0.0.1', ttl => '16'); my @p = $u->params_form; ok($u->query eq 'Subject=Meeting&Priority=Urgent' && $u->params eq 'maddr=127.0.0.1;ttl=16' && @p == 4 && "@p" eq "maddr 127.0.0.1 ttl 16"); $u = URI->new_abs('sip:phone@domain.ext', 'sip:foo@domain2.ext'); is($u, 'sip:phone@domain.ext'); $u = URI->new('sip:phone@domain.ext'); is($u, $u->abs('http://www.cpan.org/')); is($u, $u->rel('http://www.cpan.org/')); ��pop.t��0000644��00000001474�15125162450�0005536 0��ustar�00��use strict; use warnings; use Test::More tests => 8; use URI (); my $u = URI->new('pop://aas@pop.sn.no'); ok($u->user eq "aas" && !defined($u->auth) && $u->host eq "pop.sn.no" && $u->port == 110 && $u eq 'pop://aas@pop.sn.no'); $u->auth("+APOP"); ok($u->auth eq "+APOP" && $u eq 'pop://aas;AUTH=+APOP@pop.sn.no'); $u->user("gisle"); ok($u->user eq "gisle" && $u eq 'pop://gisle;AUTH=+APOP@pop.sn.no'); $u->port(4000); is($u, 'pop://gisle;AUTH=+APOP@pop.sn.no:4000'); $u = URI->new("pop:"); $u->host("pop.sn.no"); $u->user("aas"); $u->auth(""); is($u, 'pop://aas;AUTH=@pop.sn.no'); $u->auth(undef); is($u, 'pop://aas@pop.sn.no'); $u->user(undef); is($u, 'pop://pop.sn.no'); # Try some funny characters too $u->user('f�r;k@l'); ok($u->user eq 'f�r;k@l' && $u eq 'pop://f%E5r%3Bk%40l@pop.sn.no'); ��sq-brackets-legacy.t��0000644��00000002125�15125162450�0010413 0��ustar�00��use strict; use warnings; use Test::More; BEGIN { $ENV{URI_HAS_RESERVED_SQUARE_BRACKETS} = 1; } use URI (); sub show { diag explain("self: ", shift); } #-- test bugfix of https://github.com/libwww-perl/URI/issues/99 no warnings; #-- don't complain about the fragment # being a potential comment my @legacy_tests = qw( ftp://[::1]/ http://example.com/path_with_square_[brackets] http://[::1]/and_[%5Bmixed%5D]_stuff_in_path https://[::1]/path_with_square_[brackets]_and_query?par=value[1]&par=value[2] http://[::1]/path_with_square_[brackets]_and_query?par=value[1]#and_fragment[2] https://root[user]@[::1]/welcome.html ); use warnings; is( URI::HAS_RESERVED_SQUARE_BRACKETS, 1, "constant indicates to treat square brackets as reserved characters (legacy)" ); foreach my $same ( @legacy_tests ) { my $u = URI->new( $same ); is( $u->canonical, $same, "legacy: reserved square brackets not escaped" ) or show $u; } done_testing; ��heuristic.t��0000644��00000006327�15125162450�0006741 0��ustar�00��use strict; use warnings; BEGIN { # mock up a gethostbyname that always works :-) CORE::GLOBAL::gethostbyname = sub { my $name = shift; #print "# gethostbyname [$name]\n"; die if wantarray; return 1 if $name =~ /^www\.perl\.(com\|org\|ca\|su)\.$/; return 1 if $name eq "www.perl.co.uk\."; return 0; }; } use Test::More tests => 26; use URI::Heuristic qw( uf_url uf_urlstr ); if (shift) { $URI::Heuristic::DEBUG++; open(STDERR, ">&STDOUT"); # redirect STDERR } is(uf_urlstr("http://www.sn.no/"), "http://www.sn.no/"); if ($^O eq "MacOS") { is(uf_urlstr("etc:passwd"), "file:/etc/passwd"); } else { is(uf_urlstr("/etc/passwd"), "file:/etc/passwd"); } if ($^O eq "MacOS") { is(uf_urlstr(":foo.txt"), "file:./foo.txt"); } else { is(uf_urlstr("./foo.txt"), "file:./foo.txt"); } is(uf_urlstr("ftp.aas.no/lwp.tar.gz"), "ftp://ftp.aas.no/lwp.tar.gz"); if($^O eq "MacOS") { # its a weird, but valid, MacOS path, so it can't be left alone is(uf_urlstr("C:\\CONFIG.SYS"), "file:/C/%5CCONFIG.SYS"); } else { is(uf_urlstr("C:\\CONFIG.SYS"), "file:C:\\CONFIG.SYS"); } { local $ENV{LC_ALL} = ""; local $ENV{LANG} = ""; local $ENV{HTTP_ACCEPT_LANGUAGE} = ""; $ENV{LC_ALL} = "en_GB.UTF-8"; undef $URI::Heuristic::MY_COUNTRY; like(uf_urlstr("perl/camel.gif"), qr,^http://www\.perl\.(org\|co)\.uk/camel\.gif$,); use Net::Domain (); $ENV{LC_ALL} = "C"; { no warnings; Net::Domain::hostfqdn = sub { return 'vasya.su' } } undef $URI::Heuristic::MY_COUNTRY; is(uf_urlstr("perl/camel.gif"), "http://www.perl.su/camel.gif"); $ENV{LC_ALL} = "C"; { no warnings; Net::Domain::hostfqdn = sub { return '' } } undef $URI::Heuristic::MY_COUNTRY; like(uf_urlstr("perl/camel.gif"), qr,^http://www\.perl\.(com\|org)/camel\.gif$,); $ENV{HTTP_ACCEPT_LANGUAGE} = "en-ca"; undef $URI::Heuristic::MY_COUNTRY; is(uf_urlstr("perl/camel.gif"), "http://www.perl.ca/camel.gif"); } $URI::Heuristic::MY_COUNTRY = "bv"; like(uf_urlstr("perl/camel.gif"), qr,^http://www\.perl\.(com\|org)/camel\.gif$,); # Backwards compatibility; uk != United Kingdom in ISO 3166 $URI::Heuristic::MY_COUNTRY = "uk"; like(uf_urlstr("perl/camel.gif"), qr,^http://www\.perl\.(org\|co)\.uk/camel\.gif$,); $URI::Heuristic::MY_COUNTRY = "gb"; like(uf_urlstr("perl/camel.gif"), qr,^http://www\.perl\.(org\|co)\.uk/camel\.gif$,); $ENV{URL_GUESS_PATTERN} = "www.ACME.org www.ACME.com"; is(uf_urlstr("perl"), "http://www.perl.org"); { local $ENV{URL_GUESS_PATTERN} = ""; is(uf_urlstr("perl"), "http://perl"); is(uf_urlstr("http:80"), "http:80"); is(uf_urlstr("mailto:gisle\@aas.no"), "mailto:gisle\@aas.no"); is(uf_urlstr("gisle\@aas.no"), "mailto:gisle\@aas.no"); is(uf_urlstr("Gisle.Aas\@aas.perl.org"), "mailto:Gisle.Aas\@aas.perl.org"); is(uf_url("gopher.sn.no")->scheme, "gopher"); is(uf_urlstr("123.3.3.3:8080/foo"), "http://123.3.3.3:8080/foo"); is(uf_urlstr("123.3.3.3:443/foo"), "https://123.3.3.3:443/foo"); is(uf_urlstr("123.3.3.3:21/foo"), "ftp://123.3.3.3:21/foo"); is(uf_url("FTP.example.com")->scheme, "ftp"); is(uf_url("ftp2.example.com")->scheme, "ftp"); is(uf_url("ftp")->scheme, "ftp"); is(uf_url("https.example.com")->scheme, "https"); } ��mms.t��0000644��00000001053�15125162450�0005525 0��ustar�00��use strict; use warnings; use Test::More tests => 8; use URI (); my $u = URI->new("<mms://66.250.188.13/KFOG_FM>"); #print "$u\n"; is($u, "mms://66.250.188.13/KFOG_FM"); is($u->port, 1755); # play with port my $old = $u->port(8755); ok($old == 1755 && $u eq "mms://66.250.188.13:8755/KFOG_FM"); $u->port(1755); is($u, "mms://66.250.188.13:1755/KFOG_FM"); $u->port(""); ok($u eq "mms://66.250.188.13:/KFOG_FM" && $u->port == 1755); $u->port(undef); is($u, "mms://66.250.188.13/KFOG_FM"); is($u->host, "66.250.188.13"); is($u->path, "/KFOG_FM"); ��old-absconf.t��0000644��00000001332�15125162450�0007120 0��ustar�00��use strict; use warnings; use Test::More tests => 6; use URI::URL qw( url ); # Test configuration via some global variables. $URI::URL::ABS_REMOTE_LEADING_DOTS = 1; $URI::URL::ABS_ALLOW_RELATIVE_SCHEME = 1; my $u1 = url("../../../../abc", "http://web/a/b"); is($u1->abs->as_string, "http://web/abc"); { local $URI::URL::ABS_REMOTE_LEADING_DOTS; is($u1->abs->as_string, "http://web/../../../abc"); } $u1 = url("http:../../../../abc", "http://web/a/b"); is($u1->abs->as_string, "http://web/abc"); { local $URI::URL::ABS_ALLOW_RELATIVE_SCHEME; is($u1->abs->as_string, "http:../../../../abc"); is($u1->abs(undef,1)->as_string, "http://web/abc"); } is($u1->abs(undef,0)->as_string, "http:../../../../abc"); ��storable-test.pl��0000644��00000001101�15125162450�0007663 0��ustar�00��use strict; use warnings; use Storable qw( retrieve store ); if (@ARGV && $ARGV[0] eq "store") { require URI; require URI::URL; my $a = { u => new URI('http://search.cpan.org/'), }; print "# store\n"; store [URI->new("http://search.cpan.org")], 'urls.sto'; } else { require Test::More; Test::More->import(tests => 3); note("retrieve"); my $a = retrieve 'urls.sto'; my $u = $a->[0]; #use Data::Dumper; print Dumper($a); is($u, "http://search.cpan.org"); is($u->scheme, "http"); is(ref($u), "URI::http"); } ��split.t��0000644��00000001742�15125162450�0006071 0��ustar�00��use strict; use warnings; use Test::More tests => 17; use URI::Split qw( uri_join uri_split ); sub j { join("-", map { defined($_) ? $_ : "<undef>" } @_) } is j(uri_split("p")), "<undef>-<undef>-p-<undef>-<undef>"; is j(uri_split("p?q")), "<undef>-<undef>-p-q-<undef>"; is j(uri_split("p#f")), "<undef>-<undef>-p-<undef>-f"; is j(uri_split("p?q/#f/?")), "<undef>-<undef>-p-q/-f/?"; is j(uri_split("s://a/p?q#f")), "s-a-/p-q-f"; is uri_join("s", "a", "/p", "q", "f"), "s://a/p?q#f"; is uri_join("s", "a", "p", "q", "f"), "s://a/p?q#f"; is uri_join(undef, undef, "", undef, undef), ""; is uri_join(undef, undef, "p", undef, undef), "p"; is uri_join("s", undef, "p"), "s:p"; is uri_join("s"), "s:"; is uri_join(), ""; is uri_join("s", "a"), "s://a"; is uri_join("s", "a/b"), "s://a%2Fb"; is uri_join("s", ":/?#", ":/?#", ":/?#", ":/?#"), "s://:%2F%3F%23/:/%3F%23?:/?%23#:/?#"; is uri_join(undef, undef, "a:b"), "a%3Ab"; is uri_join("s", undef, "//foo//bar"), "s:////foo//bar"; ��otpauth.t��0000644��00000020455�15125162450�0006424 0��ustar�00��#!perl use strict; use warnings; use URI; use Test::More tests => 86; { my $uri = URI->new( 'otpauth://totp/Example:alice@google.com?secret=JBSWY3DPEHPK3PXP&issuer=Example' ); ok $uri, "created $uri"; isa_ok $uri, 'URI::otpauth'; is $uri->type(), 'totp', 'type'; is $uri->label(), 'Example:alice@google.com', 'label'; is $uri->issuer(), 'Example', 'issuer'; is $uri->secret(), 'Hello!' . (chr 0xDE) . (chr 0xAD) . (chr 0xBE) . (chr 0xEF), 'secret'; is $uri->counter(), undef, 'counter'; is $uri->algorithm(), 'SHA1', 'algorithm'; is $uri->digits(), 6, 'digits'; is $uri->period(), 30, 'period'; is $uri->fragment(), undef, 'fragment'; my $new_secret = 'this_is_really secret!'; $uri->secret($new_secret); my $new_uri = URI->new( "$uri" ); ok $new_uri, "created $new_uri"; isa_ok $new_uri, 'URI::otpauth'; unlike $new_uri, qr/secret=$new_secret/, 'no clear text secret'; is $new_uri->type(), 'totp', 'type'; is $new_uri->label(), 'Example:alice@google.com', 'label'; is $new_uri->account_name(), 'alice@google.com', 'account_name'; is $new_uri->issuer(), 'Example', 'issuer'; is $new_uri->secret(), $new_secret, 'secret'; is $new_uri->counter(), undef, 'counter'; is $new_uri->algorithm(), 'SHA1', 'algorithm'; is $new_uri->digits(), 6, 'digits'; is $new_uri->period(), 30, 'period'; is $new_uri->fragment(), undef, 'fragment'; my $next_uri = URI->new( 'otpauth://totp/alice@google.com?secret=JBSWY3DPEHPK3PXP&issuer=Example&digits=8&algorithm=SHA256' ); ok $next_uri, "created $next_uri"; isa_ok $next_uri, 'URI::otpauth'; is $next_uri->type(), 'totp', 'type'; is $next_uri->label(), 'Example:alice@google.com', 'label'; is $next_uri->account_name(), 'alice@google.com', 'account_name'; is $next_uri->issuer(), 'Example', 'issuer'; is $next_uri->secret(), 'Hello!' . (chr 0xDE) . (chr 0xAD) . (chr 0xBE) . (chr 0xEF), 'secret'; is $next_uri->counter(), undef, 'counter'; is $next_uri->algorithm(), 'SHA256', 'algorithm'; is $next_uri->digits(), 8, 'digits'; is $next_uri->period(), 30, 'period'; is $next_uri->fragment(), undef, 'fragment'; my $issuer_uri = URI->new( 'otpauth://totp/Example:alice@google.com?secret=JBSWY3DPEHPK3PXP' ); ok $issuer_uri, "created $issuer_uri"; isa_ok $issuer_uri, 'URI::otpauth'; is $issuer_uri->type(), 'totp', 'type'; is $issuer_uri->label(), 'Example:alice@google.com', 'label'; is $issuer_uri->account_name(), 'alice@google.com', 'account_name'; is $issuer_uri->issuer(), 'Example', 'issuer'; is $issuer_uri->secret(), 'Hello!' . (chr 0xDE) . (chr 0xAD) . (chr 0xBE) . (chr 0xEF), 'secret'; is $issuer_uri->counter(), undef, 'counter'; is $issuer_uri->algorithm(), 'SHA1', 'algorithm'; is $issuer_uri->digits(), 6, 'digits'; is $issuer_uri->period(), 30, 'period'; is $issuer_uri->fragment(), undef, 'fragment'; my $issuer2_uri = URI->new( 'otpauth://hotp/Example:alice@google.com?&issuer=Example2&counter=23&period=15' ); ok $issuer2_uri, "created $issuer2_uri"; isa_ok $issuer2_uri, 'URI::otpauth'; is $issuer2_uri->type(), 'hotp', 'type'; is $issuer2_uri->label(), 'Example2:alice@google.com', 'label'; is $issuer2_uri->issuer(), 'Example2', 'issuer'; is $issuer2_uri->secret(), undef, 'secret'; is $issuer2_uri->counter(), 23, 'counter'; is $issuer2_uri->algorithm(), 'SHA1', 'algorithm'; is $issuer2_uri->digits(), 6, 'digits'; is $issuer2_uri->period(), 15, 'period'; is $issuer2_uri->fragment(), undef, 'fragment'; } # vim:ts=2:sw=2:et:ft=perl my @case = ( { name => 'Hotp', args => { secret => "topsecret", type => 'hotp', issuer => 'Foo', counter => 6, account_name => 'bob@example.com' }, secret => "topsecret", type => 'hotp', issuer => 'Foo', account_name => 'bob@example.com', counter => 6, algorithm => 'SHA1', period => 30, }, { name => 'Only Account Name', args => { secret => "justabunchofstuff", account_name => 'alice@example.org', algorithm => 'SHA512', period => 7 }, secret => "justabunchofstuff", type => 'totp', issuer => undef, account_name => 'alice@example.org', counter => undef, algorithm => 'SHA512', period => 7, }, { name => 'Only mandatory', args => { secret => "justabunchofstuff" }, secret => "justabunchofstuff", type => 'totp', issuer => undef, account_name => undef, counter => undef, algorithm => 'SHA1', period => 30, }, ); for my $case ( @case ) { my ( $name, $args, $secret, $type, $issuer, $account_name, $counter, $algorithm, $period, $frag ) = @{$case}{ qw(name args secret type issuer account_name counter algorithm period frag) }; my $uri = URI::otpauth->new( %$args ); ok $uri, "created $uri"; is $uri->scheme(), 'otpauth', "$name: scheme"; is $uri->type(), $type, "$name: type"; is $uri->secret(), $secret, "$name: secret"; is $uri->issuer(), $issuer, "$name: issuer"; if (defined $issuer) { is $uri->label(), (join q[:], $issuer, $account_name), "$name: label"; } is $uri->algorithm(), $algorithm, "$name: algorithm"; is $uri->counter(), $counter, "$name: counter"; is $uri->period(), $period, "$name: period"; } eval { URI::otpauth->new( type => 'totp' ); }; like $@, qr/^secret is a mandatory parameter for URI::otpauth/, "missing secret"; my $doc1_uri = URI->new( 'otpauth://totp/Example:alice@google.com?secret=NFZS25DINFZV643VOAZXELLTGNRXEM3UH4&issuer=Example' ); my $doc2_uri = URI::otpauth->new( type => 'totp', issuer => 'Example', account_name => 'alice@google.com', secret => 'is-this_sup3r-s3cr3t?' ); diag "doc1_uri is $doc1_uri"; diag "doc2_uri is $doc2_uri"; is "$doc1_uri", "$doc2_uri", "$doc1_uri: matches"; # vim:ts=2:sw=2:et:ft=perl ��data.t��0000644��00000004434�15125162450�0005650 0��ustar�00��use strict; use warnings; use Test::More tests => 22; use URI (); my $u = URI->new("data:,A%20brief%20note"); ok($u->scheme eq "data" && $u->opaque eq ",A%20brief%20note"); ok($u->media_type eq "text/plain;charset=US-ASCII" && $u->data eq "A brief note"); my $old = $u->data("F�r-i-k�l er tingen!"); ok($old eq "A brief note" && $u eq "data:,F%E5r-i-k%E5l%20er%20tingen!"); $old = $u->media_type("text/plain;charset=iso-8859-1"); ok($old eq "text/plain;charset=US-ASCII" && $u eq "data:text/plain;charset=iso-8859-1,F%E5r-i-k%E5l%20er%20tingen!"); $u = URI->new("data:image/gif;base64,R0lGODdhMAAwAPAAAAAAAP///ywAAAAAMAAwAAAC8IyPqcvt3wCcDkiLc7C0qwyGHhSWpjQu5yqmCYsapyuvUUlvONmOZtfzgFzByTB10QgxOR0TqBQejhRNzOfkVJ+5YiUqrXF5Y5lKh/DeuNcP5yLWGsEbtLiOSpa/TPg7JpJHxyendzWTBfX0cxOnKPjgBzi4diinWGdkF8kjdfnycQZXZeYGejmJlZeGl9i2icVqaNVailT6F5iJ90m6mvuTS4OK05M0vDk0Q4XUtwvKOzrcd3iq9uisF81M1OIcR7lEewwcLp7tuNNkM3uNna3F2JQFo97Vriy/Xl4/f1cf5VWzXyym7PHhhx4dbgYKAAA7"); is($u->media_type, "image/gif"); if ($ENV{DISPLAY} && $ENV{XV}) { open(XV, "\| $ENV{XV} -") \|\| die; print XV $u->data; close(XV); } is(length($u->data), 273); $u = URI->new("data:text/plain;charset=iso-8859-7,%be%fg%be"); # %fg is($u->data, "\xBE%fg\xBE"); $u = URI->new("data:application/vnd-xxx-query,select_vcount,fcol_from_fieldtable/local"); is($u->data, "select_vcount,fcol_from_fieldtable/local"); $u->data(""); is($u, "data:application/vnd-xxx-query,"); $u->data("a,b"); $u->media_type(undef); is($u, "data:,a,b"); # Test automatic selection of URI/BASE64 encoding $u = URI->new("data:"); $u->data(""); is($u, "data:,"); $u->data(">"); ok($u eq "data:,%3E" && $u->data eq ">"); $u->data(">>>>>"); is($u, "data:,%3E%3E%3E%3E%3E"); $u->data(">>>>>>"); is($u, "data:;base64,Pj4+Pj4+"); $u->media_type("text/plain;foo=bar"); is($u, "data:text/plain;foo=bar;base64,Pj4+Pj4+"); $u->media_type("foo"); is($u, "data:foo;base64,Pj4+Pj4+"); $u->data(">" x 3000); ok($u eq ("data:foo;base64," . ("Pj4+" x 1000)) && $u->data eq (">" x 3000)); $u->media_type(undef); $u->data(undef); is($u, "data:,"); $u = URI->new("data:foo"); is($u->media_type("bar,b�z"), "foo"); is($u->media_type, "bar,b�z"); $old = $u->data("new"); ok($old eq "" && $u eq "data:bar%2Cb%E5z,new"); is(URI->new('data:;base64,%51%6D%70%76%5A%58%4A%75')->data, "Bjoern"); ��http.t��0000644��00000002123�15125162450�0005707 0��ustar�00��use strict; use warnings; use Test::More tests => 16; use URI (); my $u = URI->new("<http://www.example.com/path?q=f�o>"); #print "$u\n"; is($u, "http://www.example.com/path?q=f%F4o"); is($u->port, 80); # play with port my $old = $u->port(8080); ok($old == 80 && $u eq "http://www.example.com:8080/path?q=f%F4o"); $u->port(80); is($u, "http://www.example.com:80/path?q=f%F4o"); $u->port(""); ok($u eq "http://www.example.com:/path?q=f%F4o" && $u->port == 80); $u->port(undef); is($u, "http://www.example.com/path?q=f%F4o"); my @q = $u->query_form; is_deeply(\@q, ["q", "f�o"]); $u->query_form(foo => "bar", bar => "baz"); is($u->query, "foo=bar&bar=baz"); is($u->host, "www.example.com"); is($u->path, "/path"); ok(!$u->secure); $u->scheme("https"); is($u->port, 443); is($u, "https://www.example.com/path?foo=bar&bar=baz"); ok($u->secure); $u = URI->new("http://%65%78%61%6d%70%6c%65%2e%63%6f%6d/%70%75%62/%61/%32%30%30%31/%30%38/%32%37/%62%6a%6f%72%6e%73%74%61%64%2e%68%74%6d%6c"); is($u->canonical, "http://example.com/pub/a/2001/08/27/bjornstad.html"); ok($u->has_recognized_scheme); ��roy-test.t��0000644��00000001650�15125162450�0006522 0��ustar�00��use strict; use warnings; use Test::More tests => 102; use URI (); use File::Spec::Functions qw( catfile ); my $no = 1; my @prefix; push(@prefix, "t") if -d "t"; for my $i (1..5) { my $file = catfile(@prefix, "roytest$i.html"); open(FILE, $file) \|\| die "Can't open $file: $!"; note $file; my $base = undef; while (<FILE>) { if (/^<BASE href="([^"]+)">/) { $base = URI->new($1); } elsif (/^<a href="([^"])">.<\/a>\s=\s(\S+)/) { die "Missing base at line $." unless $base; my $link = $1; my $exp = $2; $exp = $base if $exp =~ /current/; # special case test 22 # rfc2396bis restores the rfc1808 behaviour if ($no == 7) { $exp = "http://a/b/c/d;p?y"; } elsif ($no == 48) { $exp = "http://a/b/c/d;p?y"; } is(URI->new($link)->abs($base), $exp); $no++; } } close(FILE); } ��roytest2.html��0000644��00000007074�15125162450�0007236 0��ustar�00��<HTML><HEAD> <TITLE>Examples of Resolving Relative URLs, Part 2</TITLE> <BASE href="http://a/b/c/d;p?q=1/2"> </HEAD><BODY> <H1>Examples of Resolving Relative URLs, Part 2</H1> This document has an embedded base URL of <PRE> Content-Base: http://a/b/c/d;p?q=1/2 </PRE> the relative URLs should be resolved as shown below. In this test page, I am particularly interested in testing whether "/" in query information is or is not treated as part of the path hierarchy. <P> I will need your help testing the examples on multiple browsers. What you need to do is point to the example anchor and compare it to the resolved URL in your browser (most browsers have a feature by which you can see the resolved URL at the bottom of the window/screen when the anchor is active). <H2>Tested Clients and Client Libraries</H2> <DL COMPACT> <DT>[R] <DD>RFC 2396 (the right way to parse) <DT>[X] <DD>RFC 1808 <DT>[1] <DD>Mozilla/4.03 [en] (X11; U; SunOS 5.5 sun4u; Nav) <DT>[2] <DD>Lynx/2.7.1 libwww-FM/2.14 <DT>[3] <DD>MSIE 3.01; Windows 95 <DT>[4] <DD>NCSA_Mosaic/2.6 (X11;SunOS 4.1.2 sun4m) libwww/2.12 </DL> <H3>Synopsis</H3> RFC 1808 specified that the "/" character within query information does not affect the hierarchy within URL parsing. It would appear that it does in current practice, but only within the relative path after it is attached to the base path. In other words, the base URL's query information is being stripped off before any relative resolution, but some parsers fail to separate the query information from the relative path.<P> We have decided that this behavior is due to an oversight in the original libwww implementation, and it is better to correct the oversight in future parsers than it is to make a nonsensical standard. A note has been added to the URI draft to account for the differences in implementations. This should have no impact on current practice since unescaped "/" is rarely (if ever) used within the query part of a URL, and query parts themselves are rarely used with relative URLs. <H2>Examples</H2> <PRE> RESULTS from <a href="g">g</a> = http://a/b/c/g [R,X,1,2,3,4] <a href="./g">./g</a> = http://a/b/c/g [R,X,1,2,3,4] <a href="g/">g/</a> = http://a/b/c/g/ [R,X,1,2,3,4] <a href="/g">/g</a> = http://a/g [R,X,1,2,3,4] <a href="//g">//g</a> = http://g [R,X,1,2,3,4] <a href="?y">?y</a> = http://a/b/c/?y [R,1,2,3,4] http://a/b/c/d;p?y [X] <a href="g?y">g?y</a> = http://a/b/c/g?y [R,X,1,2,3,4] <a href="g?y/./x">g?y/./x</a> = http://a/b/c/g?y/./x [R,X] http://a/b/c/g?y/x [1,2,3,4] <a href="g?y/../x">g?y/../x</a> = http://a/b/c/g?y/../x [R,X] http://a/b/c/x [1,2,3,4] <a href="g#s">g#s</a> = http://a/b/c/g#s [R,X,1,2,3,4] <a href="g#s/./x">g#s/./x</a> = http://a/b/c/g#s/./x [R,X,2,3,4] http://a/b/c/g#s/x [1] <a href="g#s/../x">g#s/../x</a> = http://a/b/c/g#s/../x [R,X,2,3,4] http://a/b/c/x [1] <a href="./">./</a> = http://a/b/c/ [R,X,1,2,3,4] <a href="../">../</a> = http://a/b/ [R,X,1,2,3,4] <a href="../g">../g</a> = http://a/b/g [R,X,1,2,3,4] <a href="../../">../../</a> = http://a/ [R,X,1,2,3,4] <a href="../../g">../../g</a> = http://a/g [R,X,1,2,3,4] </PRE> </BODY></HTML> ��generic.t��0000644��00000007323�15125162450�0006353 0��ustar�00��use strict; use warnings; use Test::More tests => 48; use URI (); my $foo = URI->new("Foo:opaque#frag"); is(ref($foo), "URI::_foreign"); is($foo->as_string, "Foo:opaque#frag"); is("$foo", "Foo:opaque#frag"); # Try accessors ok($foo->_scheme eq "Foo" && $foo->scheme eq "foo" && !$foo->has_recognized_scheme); is($foo->opaque, "opaque"); is($foo->fragment, "frag"); is($foo->canonical, "foo:opaque#frag"); # Try modificators my $old = $foo->scheme("bar"); ok($old eq "foo" && $foo eq "bar:opaque#frag"); $old = $foo->scheme(""); ok($old eq "bar" && $foo eq "opaque#frag"); $old = $foo->scheme("foo"); $old = $foo->scheme(undef); ok($old eq "foo" && $foo eq "opaque#frag"); $foo->scheme("foo"); $old = $foo->opaque("xxx"); ok($old eq "opaque" && $foo eq "foo:xxx#frag"); $old = $foo->opaque(""); ok($old eq "xxx" && $foo eq "foo:#frag"); $old = $foo->opaque(" #?/"); $old = $foo->opaque(undef); ok($old eq "%20%23?/" && $foo eq "foo:#frag"); $foo->opaque("opaque"); $old = $foo->fragment("x"); ok($old eq "frag" && $foo eq "foo:opaque#x"); $old = $foo->fragment(""); ok($old eq "x" && $foo eq "foo:opaque#"); $old = $foo->fragment(undef); ok($old eq "" && $foo eq "foo:opaque"); # Compare ok($foo->eq("Foo:opaque") && $foo->eq(URI->new("FOO:opaque")) && $foo->eq("foo:opaque")); ok(!$foo->eq("Bar:opaque") && !$foo->eq("foo:opaque#")); # Try hierarchal unknown URLs $foo = URI->new("foo://host:80/path?query#frag"); is("$foo", "foo://host:80/path?query#frag"); # Accessors is($foo->scheme, "foo"); is($foo->authority, "host:80"); is($foo->path, "/path"); is($foo->query, "query"); is($foo->fragment, "frag"); # Modificators $old = $foo->authority("xxx"); ok($old eq "host:80" && $foo eq "foo://xxx/path?query#frag"); $old = $foo->authority(""); ok($old eq "xxx" && $foo eq "foo:///path?query#frag"); $old = $foo->authority(undef); ok($old eq "" && $foo eq "foo:/path?query#frag"); $old = $foo->authority("/? #;@&"); ok(!defined($old) && $foo eq "foo://%2F%3F%20%23;@&/path?query#frag"); $old = $foo->authority("host:80"); ok($old eq "%2F%3F%20%23;@&" && $foo eq "foo://host:80/path?query#frag"); $old = $foo->path("/foo"); ok($old eq "/path" && $foo eq "foo://host:80/foo?query#frag"); $old = $foo->path("bar"); ok($old eq "/foo" && $foo eq "foo://host:80/bar?query#frag"); $old = $foo->path(""); ok($old eq "/bar" && $foo eq "foo://host:80?query#frag"); $old = $foo->path(undef); ok($old eq "" && $foo eq "foo://host:80?query#frag"); $old = $foo->path("@;/?#"); ok($old eq "" && $foo eq "foo://host:80/@;/%3F%23?query#frag"); $old = $foo->path("path"); ok($old eq "/@;/%3F%23" && $foo eq "foo://host:80/path?query#frag"); $old = $foo->query("foo"); ok($old eq "query" && $foo eq "foo://host:80/path?foo#frag"); $old = $foo->query(""); ok($old eq "foo" && $foo eq "foo://host:80/path?#frag"); $old = $foo->query(undef); ok($old eq "" && $foo eq "foo://host:80/path#frag"); $old = $foo->query("/?&=# "); ok(!defined($old) && $foo eq "foo://host:80/path?/?&=%23%20#frag"); $old = $foo->query("query"); ok($old eq "/?&=%23%20" && $foo eq "foo://host:80/path?query#frag"); # Some buildup trics $foo = URI->new(""); $foo->path("path"); $foo->authority("auth"); is($foo, "//auth/path"); $foo = URI->new("", "http:"); $foo->query("query"); $foo->authority("auth"); ok($foo eq "//auth?query" && $foo->has_recognized_scheme); $foo->path("path"); is($foo, "//auth/path?query"); $foo = URI->new(""); $old = $foo->path("foo"); ok($old eq "" && $foo eq "foo" && !$foo->has_recognized_scheme); $old = $foo->path("bar"); ok($old eq "foo" && $foo eq "bar"); $old = $foo->opaque("foo"); ok($old eq "bar" && $foo eq "foo"); $old = $foo->path(""); ok($old eq "foo" && $foo eq ""); $old = $foo->query("q"); ok(!defined($old) && $foo eq "?q"); ��urn-oid.t��0000644��00000000426�15125162450�0006311 0��ustar�00��use strict; use warnings; use Test::More tests => 4; use URI (); my $u = URI->new("urn:oid"); $u->oid(1..10); #print "$u\n"; is($u, "urn:oid:1.2.3.4.5.6.7.8.9.10"); is($u->oid, "1.2.3.4.5.6.7.8.9.10"); ok($u->scheme eq "urn" && $u->nid eq "oid"); is($u->oid, $u->nss); ��file.t��0000644��00000007161�15125162450�0005656 0��ustar�00��use strict; use warnings; use Test::More; use URI::file (); subtest 'OS related tests (unix, win32, mac)' => sub { my @tests = ( ["file", "unix", "win32", "mac"], #---------------- ------------ --------------- -------------- ["file://localhost/foo/bar", "!/foo/bar", "!\\foo\\bar", "!foo:bar",], ["file:///foo/bar", "/foo/bar", "\\foo\\bar", "!foo:bar",], ["file:/foo/bar", "!/foo/bar", "!\\foo\\bar", "foo:bar",], ["foo/bar", "foo/bar", "foo\\bar", ":foo:bar",], [ "file://foo3445x/bar", "!//foo3445x/bar", "!\\\\foo3445x\\bar", "!foo3445x:bar" ], ["file://a:/", "!//a:/", "!A:\\", undef], ["file:///A:/", "/A:/", "A:\\", undef], ["file:///", "/", "\\", undef], [".", ".", ".", ":"], ["..", "..", "..", "::"], ["%2E", "!.", "!.", ":."], ["../%2E%2E", "!../..", "!..\\..", "::.."], ); my @os = @{shift @tests}; shift @os; # file for my $t (@tests) { my @t = @$t; my $file = shift @t; my $u = URI->new($file, "file"); my $i = 0; for my $os (@os) { my $f = $u->file($os); my $expect = $t[$i]; $f = "<undef>" unless defined $f; $expect = "<undef>" unless defined $expect; my $loose; $loose++ if $expect =~ s/^!//; is($f, $expect) or diag "URI->new('$file', 'file')->file('$os')"; if (defined($t[$i]) && !$loose) { my $u2 = URI::file->new($t[$i], $os); is($u2->as_string, $file) or diag "URI::file->new('$t[$i]', '$os')"; } $i++; } } }; SKIP: { skip "No pre 5.11 regression tests yet.", 1 if URI::HAS_RESERVED_SQUARE_BRACKETS; subtest "Including Domains" => sub { is( URI->new('file://example.com/tmp/file.part[1]'), 'file://example.com/tmp/file.part%5B1%5D' ); is( URI->new('file://127.0.0.1/tmp/file.part[2]'), 'file://127.0.0.1/tmp/file.part%5B2%5D' ); is( URI->new('file://localhost/tmp/file.part[3]'), 'file://localhost/tmp/file.part%5B3%5D' ); is( URI->new('file://[1:2:3::beef]/tmp/file.part[4]'), 'file://[1:2:3::beef]/tmp/file.part%5B4%5D' ); is( URI->new('file:///[1:2:3::1ce]/tmp/file.part[5]'), 'file:///%5B1:2:3::1ce%5D/tmp/file.part%5B5%5D' ); }; } subtest "Regression Tests" => sub { # Regression test for https://github.com/libwww-perl/URI/issues/102 { my $with_hashes = URI::file->new_abs("/tmp/###"); is($with_hashes, 'file:///tmp/%23%23%23', "issue GH#102"); } # URI 5.11 introduced a bug where URI::file could return the current # working directory instead of the path defined. # The bug was caused by a wrong quantifier in a regular expression in # URI::_fix_uric_escape_for_host_part() which returned an empty string for # all URIs that needed escaping ('%xx') but did not have a host part. # The empty string in turn caused URI::file->new_abs() to use the current # working directory as a default. { my $file_path = URI::file->new_abs('/a/path/that/pretty likely/does/not/exist-yie1Ahgh0Ohlahqueirequ0iebu8ip')->file(); my $current_dir = URI::file->new_abs()->file(); isnt( $file_path, $current_dir, 'regression test for #102' ); } }; done_testing; ��punycode.t��0000644��00000004343�15125162450�0006564 0��ustar�00��use strict; use warnings; use utf8; use Test::More tests => 15; use URI::_punycode qw( decode_punycode encode_punycode ); my %RFC_3492 = ( A => { unicode => udecode("u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644 u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F"), ascii => "egbpdaj6bu4bxfgehfvwxn", }, B => { unicode => udecode("u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587"), ascii => "ihqwcrb4cv8a8dqg056pqjye", }, E => { unicode => udecode("u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8 u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2 u+05D1 u+05E8 u+05D9 u+05EA"), ascii => "4dbcagdahymbxekheh6e0a7fei0b", }, J => { unicode => udecode("U+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070 u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070 u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061 u+0062 u+006C u+0061 u+0072 u+0065 u+006E U+0045 u+0073 u+0070 u+0061 u+00F1 u+006F u+006C"), ascii => "PorqunopuedensimplementehablarenEspaol-fmd56a", }, K => { unicode => udecode("U+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068 u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067 U+0056 u+0069 u+1EC7 u+0074"), ascii => "TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g", }, O => { unicode => udecode("u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032"), ascii => "2-u9tlzr9756bt3uc0v", }, S => { unicode => "\$1.00", ascii => "\$1.00", }, ); is encode_punycode("bücher"), "bcher-kva", "http://en.wikipedia.org/wiki/Punycode example encode"; is decode_punycode("bcher-kva"), "bücher", "http://en.wikipedia.org/wiki/Punycode example decode"; for my $test_key (sort keys %RFC_3492) { my $test = $RFC_3492{$test_key}; is encode_punycode($test->{unicode}), $test->{ascii}, "$test_key encode"; is decode_punycode($test->{ascii}), $test->{unicode}, "$test_key decode" unless $test_key eq "S"; } sub udecode { my $str = shift; my @u; for (split(" ", $str)) { /^[uU]\+[\dA-F]{2,4}$/ \|\| die "Unexpected ucode: $_"; push(@u, chr(hex(substr($_, 2)))); } return join("", @u); } ��sort-hash-query-form.t��0000644��00000000542�15125162450�0010747 0��ustar�00��use strict; use warnings; use Test::More; # ABSTRACT: Make sure query_form(\%hash) is sorted use URI (); my $base = URI->new('http://example.org/'); my $i = 1; my $hash = { map { $_ => $i++ } qw( a b c d e f ) }; $base->query_form($hash); is("$base","http://example.org/?a=1&b=2&c=3&d=4&e=5&f=6", "Query parameters are sorted"); done_testing; ��cwd.t��0000644��00000000260�15125162450�0005505 0��ustar�00��use strict; use warnings; use Test::More; plan tests => 1; use URI::file (); $ENV{PATH} = "/bin:/usr/bin"; my $cwd = eval { URI::file->cwd }; is($@, '', 'no exceptions'); ��old-relbase.t��0000644��00000001354�15125162450�0007126 0��ustar�00��use strict; use warnings; use Test::More tests => 5; use URI::URL qw( url ); # We used to have problems with URLs that used a base that was # not absolute itself. my $u1 = url("/foo/bar", "http://www.acme.com/"); my $u2 = url("../foo/", $u1); my $u3 = url("zoo/foo", $u2); my $a1 = $u1->abs->as_string; my $a2 = $u2->abs->as_string; my $a3 = $u3->abs->as_string; is($a1, "http://www.acme.com/foo/bar"); is($a2, "http://www.acme.com/foo/"); is($a3, "http://www.acme.com/foo/zoo/foo"); # We used to have problems with URI::URL as the base class :-( my $u4 = url("foo", "URI::URL"); my $a4 = $u4->abs; ok($u4 eq "foo" && $a4 eq "uri:/foo"); # Test new_abs for URI::URL objects is(URI::URL->new_abs("foo", "http://foo/bar"), "http://foo/foo"); ��teraterm��0000644��00000003223�15125632216�0006315 0��ustar�00��&��i�teraterm\|Tera Term��P��@��!�%�)��4�E�G�K�R��T�[��_��c�g��k�m�r��w�\|�� '��/��37;��?HQ��Zcl��u��~�� SY��_��f��j��o��tz�� [%i%p1%d;%p2%dr�[3g�[H[J�[K�[J�[%i%p1%dG�[%i%p1%d;%p2%dH� �[H�[?25l��[?25h�[C�[A�[P�[M��[5m�[1m�[7m�[7m�[4m�[%p1%dX��[0m�[27m�[24m�[?5h$<200/>[?5l�[L��[3~�OB�Oy�[11~�[21~�[12~�[13~�[14~�[15~�[17~�[18~�[19~�[20~�[2~�OD�[6~�[5~�OC�OA�[?1l>�[?1h=�pf1�pf2�pf3�pf4�[%p1%dP�[%p1%dM�[%p1%dB�[%p1%dL�[%p1%dD�[%p1%dC�[%p1%dA�[0i�[4i�[5i�<>[?3;4;5l[?7;8h[r�8�[%i%p1%dd�7� �M�[0%?%p1%p6%\|%t;1%;%?%p2%t;4%;%?%p1%p3%\|%t;7%;%?%p4%t;5%;m%?%p9%t%e%;$<2>�H� �Oq�Os�Or�Op�On�``aaffggjjkkllmmnnooppqqrrssttuuvvwwxxyyzz{{\|\|}}~~�[?7h�[?7l�(B)0�OM�[1~�[4~�[23~�[24~�[25~�[26~�[28~�[29~�[31~�[32~�[33~�[34~�[1K�[%i%d;%dR�[6n�[?1;2c�[c�[39;49m�[<�[3%p1%dm�[4%p1%dm��Q�� [?1006;1000%?%p1%{1}%=%th%el%;�[<%i%p3%d;%p1%d;%p2%d;%?%p4%tM%em%;�AX�XT�XM�xm��teraterm2.3��0000644��00000003070�15125632216�0006540 0��ustar�00��&��i�teraterm2.3\|Tera Term Pro��P��@�+��!�%�)��4�E�G�K�R��T�[��_��c�g��k�m�r��w�\|�� '��/��37;��?HQ��Zcl��u��~�� ag��m��t��x��}�� [%i%p1%d;%p2%dr�[3g�[H[J�[K�[J�[%i%p1%dG�[%i%p1%d;%p2%dH� �[H�[?25l��[?25h�[C�[A�[P�[M��[5m�[1m�[7m�[7m�[4m�[%p1%dX��[0m�[27m�[24m�[?5h$<200/>[?5l�[L��[3~�OB�Oy�[11~�[21~�[12~�[13~�[14~�[15~�[17~�[18~�[19~�[20~�[2~�OD�[6~�[5~�OC�OA�[?1l>�[?1h=�pf1�pf2�pf3�pf4�[%p1%dP�[%p1%dM�[%p1%dB�[%p1%dL�[%p1%dD�[%p1%dC�[%p1%dA�[0i�[4i�[5i�<>[?3;4;5l[?7;8h[r�8�[%i%p1%dd�7� �M�[0%?%p1%p6%\|%t;1%;%?%p2%t;4%;%?%p1%p3%\|%t;7%;%?%p4%t;5%;m%?%p9%t%e%;$<2>�H� �Oq�Os�Or�Op�On�+,-.0�`a�f�g�h�i�j�k�l�m�n�o~p�q�r�s_t�u�v�w�x�y�z�{�\|�}�~��[?7h�[?7l�(B)0�OM�[1~�[4~�[23~�[24~�[25~�[26~�[28~�[29~�[31~�[32~�[33~�[34~�[1K�[%i%d;%dR�[6n�[?1;2c�[c�[100m�[3%p1%dm�[4%p1%dm��tmux-direct��0000644��00000006516�15125632216�0006747 0��ustar�00��,�+��i6tmux-direct\|tmux with direct-color indexing��P��%�)�-��8�I�K�O�V��X�d��h�k�q�u�y�� $��)��-27;B��IMU��]��`ir{��1��46��;��\|��$,3:AHPX`hpx�� (08@GNU��Zejrv��[Z�� [%i%p1%d;%p2%dr�[3g�[H[J�[K�[J�[%i%p1%dG�[%i%p1%d;%p2%dH� �[H�[?25l��[34h[?25h�[C�M�[34l�[P�[M�]0;��[5m�[1m�[?1049h�[2m�[4h�[8m�[7m�[7m�[4m��[m�[?1049l�[4l�[27m�[24m�g��)0�[L��[3~�OB�OP�[21~�OQ�OR�OS�[15~�[17~�[18~�[19~�[20~�[1~�[2~�OD�[6~�[5~�OC�[1;2B�[1;2A�OA�[?1l>�[?1h=�E�[%p1%dP�[%p1%dM�[%p1%dB�[%p1%d@�[%p1%dS�[%p1%dL�[%p1%dD�[%p1%dC�[%p1%dA�c[?1000l[?25h�8�[%i%p1%dd�7� �M�[0%?%p6%t;1%;%?%p2%t;4%;%?%p1%p3%\|%t;7%;%?%p4%t;5%;%?%p5%t;2%;%?%p7%t;8%;m%?%p9%t%e%;�H� �]0;�++,,--..00``aaffgghhiijjkkllmmnnooppqqrrssttuuvvwwxxyyzz{{\|\|}}~~�[Z�(B)0�[4~�[3;2~�[1;2F�[1;2H�[2;2~�[1;2D�[6;2~�[5;2~�[1;2C�[23~�[24~�[1;2P�[1;2Q�[1;2R�[1;2S�[15;2~�[17;2~�[18;2~�[19;2~�[20;2~�[21;2~�[23;2~�[24;2~�[1;5P�[1;5Q�[1;5R�[1;5S�[15;5~�[17;5~�[18;5~�[19;5~�[20;5~�[21;5~�[23;5~�[24;5~�[1;6P�[1;6Q�[1;6R�[1;6S�[15;6~�[17;6~�[18;6~�[19;6~�[20;6~�[21;6~�[23;6~�[24;6~�[1;3P�[1;3Q�[1;3R�[1;3S�[15;3~�[17;3~�[18;3~�[19;3~�[20;3~�[21;3~�[23;3~�[24;3~�[1;4P�[1;4Q�[1;4R�[1K�[%i%d;%dR�[6n�[?1;2c�[c�[39;49m�[3m�[23m�[M�[%?%p1%{8}%<%t3%p1%d%e38:2::%p1%{65536}%/%d:%p1%{256}%/%{255}%&%d:%p1%{255}%&%d%;m�[%?%p1%{8}%<%t4%p1%d%e48:2::%p1%{65536}%/%d:%p1%{256}%/%{255}%&%d:%p1%{255}%&%d%;m��A��.�6�<�G�Q�V�]�d�k�r�y��!(/6=DKRY`gnu\|�� "�%�+�.�1�6�;�@�E�J�N�S�X�]�b�g�m�s�y�� "(.48=BGLQV\]112�]12;%p1%s�(B�[3J�]52;%p1%s;%p2%s�(%p1%c�[2 q�[4:%p1%dm�[%p1%d q�]0;�[3;3~�[3;4~�[3;5~�[3;6~�[3;7~�[1;2B�[1;3B�[1;4B�[1;5B�[1;6B�[1;7B�[1;3F�[1;4F�[1;5F�[1;6F�[1;7F�[1;3H�[1;4H�[1;5H�[1;6H�[1;7H�[2;3~�[2;4~�[2;5~�[2;6~�[2;7~�[1;3D�[1;4D�[1;5D�[1;6D�[1;7D�[6;3~�[6;4~�[6;5~�[6;6~�[6;7~�[5;3~�[5;4~�[5;5~�[5;6~�[5;7~�[1;3C�[1;4C�[1;5C�[1;6C�[1;7C�[1;2A�[1;3A�[1;4A�[1;5A�[1;6A�[1;7A�[29m�[%?%p1%{8}%<%t5%p1%d%e58:2::%p1%{65536}%/%d:%p1%{256}%/%{255}%&%d:%p1%{255}%&%d%;m�[9m�AX�G0�RGB�CO�U8�Cr�Cs�E0�E3�Ms�S0�Se�Smulx�Ss�TS�kDC3�kDC4�kDC5�kDC6�kDC7�kDN�kDN3�kDN4�kDN5�kDN6�kDN7�kEND3�kEND4�kEND5�kEND6�kEND7�kHOM3�kHOM4�kHOM5�kHOM6�kHOM7�kIC3�kIC4�kIC5�kIC6�kIC7�kLFT3�kLFT4�kLFT5�kLFT6�kLFT7�kNXT3�kNXT4�kNXT5�kNXT6�kNXT7�kPRV3�kPRV4�kPRV5�kPRV6�kPRV7�kRIT3�kRIT4�kRIT5�kRIT6�kRIT7�kUP�kUP3�kUP4�kUP5�kUP6�kUP7�rmxx�setal�smxx��tmux-256color��0000644��00000006255�15125632216�0007050 0��ustar�00��#�+��i tmux-256color\|tmux with 256 colors��P��%�)�-��8�I�K�O�V��X�d��h�k�q�u�y�� $��)��-27;B��IMU��]��`ir{��1��46��;��\|��$,3:AHPX`hpx�� (08@GNU��Zejrv��[Z�� [%i%p1%d;%p2%dr�[3g�[H[J�[K�[J�[%i%p1%dG�[%i%p1%d;%p2%dH� �[H�[?25l��[34h[?25h�[C�M�[34l�[P�[M�]0;��[5m�[1m�[?1049h�[2m�[4h�[8m�[7m�[7m�[4m��[m�[?1049l�[4l�[27m�[24m�g��)0�[L��[3~�OB�OP�[21~�OQ�OR�OS�[15~�[17~�[18~�[19~�[20~�[1~�[2~�OD�[6~�[5~�OC�[1;2B�[1;2A�OA�[?1l>�[?1h=�E�[%p1%dP�[%p1%dM�[%p1%dB�[%p1%d@�[%p1%dS�[%p1%dL�[%p1%dD�[%p1%dC�[%p1%dA�c[?1000l[?25h�8�[%i%p1%dd�7� �M�[0%?%p6%t;1%;%?%p2%t;4%;%?%p1%p3%\|%t;7%;%?%p4%t;5%;%?%p5%t;2%;%?%p7%t;8%;m%?%p9%t%e%;�H� �]0;�++,,--..00``aaffgghhiijjkkllmmnnooppqqrrssttuuvvwwxxyyzz{{\|\|}}~~�[Z�(B)0�[4~�[3;2~�[1;2F�[1;2H�[2;2~�[1;2D�[6;2~�[5;2~�[1;2C�[23~�[24~�[1;2P�[1;2Q�[1;2R�[1;2S�[15;2~�[17;2~�[18;2~�[19;2~�[20;2~�[21;2~�[23;2~�[24;2~�[1;5P�[1;5Q�[1;5R�[1;5S�[15;5~�[17;5~�[18;5~�[19;5~�[20;5~�[21;5~�[23;5~�[24;5~�[1;6P�[1;6Q�[1;6R�[1;6S�[15;6~�[17;6~�[18;6~�[19;6~�[20;6~�[21;6~�[23;6~�[24;6~�[1;3P�[1;3Q�[1;3R�[1;3S�[15;3~�[17;3~�[18;3~�[19;3~�[20;3~�[21;3~�[23;3~�[24;3~�[1;4P�[1;4Q�[1;4R�[1K�[%i%d;%dR�[6n�[?1;2c�[c�[39;49m�[3m�[23m�[M�[%?%p1%{8}%<%t3%p1%d%e%p1%{16}%<%t9%p1%{8}%-%d%e38;5;%p1%d%;m�[%?%p1%{8}%<%t4%p1%d%e%p1%{16}%<%t10%p1%{8}%-%d%e48;5;%p1%d%;m��@��!��.�6�<�G�Q�V�]�d�k�r�y��!(/6=DKRY`gnu\|�� $�'��/�4�9�>�C�G�L�Q�V�[�`�f�l�r�x�~�� !'-16;@EJO]112�]12;%p1%s�(B�[3J�]52;%p1%s;%p2%s�(%p1%c�[2 q�[4:%p1%dm�[%p1%d q�]0;�[3;3~�[3;4~�[3;5~�[3;6~�[3;7~�[1;2B�[1;3B�[1;4B�[1;5B�[1;6B�[1;7B�[1;3F�[1;4F�[1;5F�[1;6F�[1;7F�[1;3H�[1;4H�[1;5H�[1;6H�[1;7H�[2;3~�[2;4~�[2;5~�[2;6~�[2;7~�[1;3D�[1;4D�[1;5D�[1;6D�[1;7D�[6;3~�[6;4~�[6;5~�[6;6~�[6;7~�[5;3~�[5;4~�[5;5~�[5;6~�[5;7~�[1;3C�[1;4C�[1;5C�[1;6C�[1;7C�[1;2A�[1;3A�[1;4A�[1;5A�[1;6A�[1;7A�[29m�[9m�AX�G0�U8�Cr�Cs�E0�E3�Ms�S0�Se�Smulx�Ss�TS�kDC3�kDC4�kDC5�kDC6�kDC7�kDN�kDN3�kDN4�kDN5�kDN6�kDN7�kEND3�kEND4�kEND5�kEND6�kEND7�kHOM3�kHOM4�kHOM5�kHOM6�kHOM7�kIC3�kIC4�kIC5�kIC6�kIC7�kLFT3�kLFT4�kLFT5�kLFT6�kLFT7�kNXT3�kNXT4�kNXT5�kNXT6�kNXT7�kPRV3�kPRV4�kPRV5�kPRV6�kPRV7�kRIT3�kRIT4�kRIT5�kRIT6�kRIT7�kUP�kUP3�kUP4�kUP5�kUP6�kUP7�rmxx�smxx��tmux��0000644��00000006035�15125632216�0005473 0��ustar�00��+��i�tmux\|tmux terminal multiplexer��P��@��%�)�-��8�I�K�O�V��X�d��h�k�q�u�y�� $��)��-27;B��IMU��]��`ir{��1��46��;��\|��$,3:AHPX`hpx�� (08@GNU��Zejrv��[Z�� [%i%p1%d;%p2%dr�[3g�[H[J�[K�[J�[%i%p1%dG�[%i%p1%d;%p2%dH� �[H�[?25l��[34h[?25h�[C�M�[34l�[P�[M�]0;��[5m�[1m�[?1049h�[2m�[4h�[8m�[7m�[7m�[4m��[m�[?1049l�[4l�[27m�[24m�g��)0�[L��[3~�OB�OP�[21~�OQ�OR�OS�[15~�[17~�[18~�[19~�[20~�[1~�[2~�OD�[6~�[5~�OC�[1;2B�[1;2A�OA�[?1l>�[?1h=�E�[%p1%dP�[%p1%dM�[%p1%dB�[%p1%d@�[%p1%dS�[%p1%dL�[%p1%dD�[%p1%dC�[%p1%dA�c[?1000l[?25h�8�[%i%p1%dd�7� �M�[0%?%p6%t;1%;%?%p2%t;4%;%?%p1%p3%\|%t;7%;%?%p4%t;5%;%?%p5%t;2%;%?%p7%t;8%;m%?%p9%t%e%;�H� �]0;�++,,--..00``aaffgghhiijjkkllmmnnooppqqrrssttuuvvwwxxyyzz{{\|\|}}~~�[Z�(B)0�[4~�[3;2~�[1;2F�[1;2H�[2;2~�[1;2D�[6;2~�[5;2~�[1;2C�[23~�[24~�[1;2P�[1;2Q�[1;2R�[1;2S�[15;2~�[17;2~�[18;2~�[19;2~�[20;2~�[21;2~�[23;2~�[24;2~�[1;5P�[1;5Q�[1;5R�[1;5S�[15;5~�[17;5~�[18;5~�[19;5~�[20;5~�[21;5~�[23;5~�[24;5~�[1;6P�[1;6Q�[1;6R�[1;6S�[15;6~�[17;6~�[18;6~�[19;6~�[20;6~�[21;6~�[23;6~�[24;6~�[1;3P�[1;3Q�[1;3R�[1;3S�[15;3~�[17;3~�[18;3~�[19;3~�[20;3~�[21;3~�[23;3~�[24;3~�[1;4P�[1;4Q�[1;4R�[1K�[%i%d;%dR�[6n�[?1;2c�[c�[39;49m�[3m�[23m�[M�[3%p1%dm�[4%p1%dm��@��!��.�6�<�G�Q�V�]�d�k�r�y��!(/6=DKRY`gnu\|�� $�'�*�/�4�9�>�C�G�L�Q�V�[�`�f�l�r�x�~�� !'-16;@EJO]112�]12;%p1%s�(B�[3J�]52;%p1%s;%p2%s�(%p1%c�[2 q�[4:%p1%dm�[%p1%d q�]0;�[3;3~�[3;4~�[3;5~�[3;6~�[3;7~�[1;2B�[1;3B�[1;4B�[1;5B�[1;6B�[1;7B�[1;3F�[1;4F�[1;5F�[1;6F�[1;7F�[1;3H�[1;4H�[1;5H�[1;6H�[1;7H�[2;3~�[2;4~�[2;5~�[2;6~�[2;7~�[1;3D�[1;4D�[1;5D�[1;6D�[1;7D�[6;3~�[6;4~�[6;5~�[6;6~�[6;7~�[5;3~�[5;4~�[5;5~�[5;6~�[5;7~�[1;3C�[1;4C�[1;5C�[1;6C�[1;7C�[1;2A�[1;3A�[1;4A�[1;5A�[1;6A�[1;7A�[29m�[9m�AX�G0�U8�Cr�Cs�E0�E3�Ms�S0�Se�Smulx�Ss�TS�kDC3�kDC4�kDC5�kDC6�kDC7�kDN�kDN3�kDN4�kDN5�kDN6�kDN7�kEND3�kEND4�kEND5�kEND6�kEND7�kHOM3�kHOM4�kHOM5�kHOM6�kHOM7�kIC3�kIC4�kIC5�kIC6�kIC7�kLFT3�kLFT4�kLFT5�kLFT6�kLFT7�kNXT3�kNXT4�kNXT5�kNXT6�kNXT7�kPRV3�kPRV4�kPRV5�kPRV6�kPRV7�kRIT3�kRIT4�kRIT5�kRIT6�kRIT7�kUP�kUP3�kUP4�kUP5�kUP6�kUP7�rmxx�smxx��

| ver. 1.6 | Github | . | PHP 8.2.30 | ??????????? ?????????: 0.07 | proxy | phpinfo | ???????????