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

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

???????
PK��V�[�[-�� roytest3.htmlnu��[��<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> PK��V�[�NF7- ��- ��query.tnu��[��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'; PK��V�[�� iri.tnu��[��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); PK��V�["3F��num_eq.tnu��[��# 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, "!="; PK��V�[�y<!��!��utf8.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 8; use utf8; is Dump("\x{100}"), "--- \xC4\x80\n", 'Dumping wide char works'; is Load("--- \xC4\x80\n"), "\x{100}", 'Loading UTF-8 works'; is Load("\xFE\xFF\0-\0-\0-\0 \x01\x00\0\n"), "\x{100}", 'Loading UTF-16BE works'; is Load("\xFF\xFE-\0-\0-\0 \0\x00\x01\n\0"), "\x{100}", 'Loading UTF-16LE works'; my $hash = { '店名' => 'OpCafé', '電話' => <<'...', 03-5277806 0991-100087 ... Email => 'boss@opcafe.net', '時間' => '11:01~23:59', '地址' => '新竹市 300 石坊街 37-8 號', }; my $yaml = <<'...'; --- Email: boss@opcafe.net 地址: 新竹市 300 石坊街 37-8 號店名: OpCafé 時間: 11:01~23:59 電話: "03-5277806\n0991-100087\n" ... utf8::encode($yaml); is Dump($hash), $yaml, 'Dumping Chinese hash works'; is_deeply Load($yaml), $hash, 'Loading Chinese hash works'; my $hash2 = { 'モジュール' => [ { '名前' => 'YAML', '作者' => {'名前' => 'インギー', '場所' => 'シアトル'}, }, { '名前' => 'Plagger', '作者' => {'名前' => '宮川達彦', '場所' => 'サンフランシスコ' }, }, ] }; my $yaml2 = <<'...'; --- モジュール: - 作者: 名前: インギー場所: シアトル名前: YAML - 作者: 名前: 宮川達彦場所: サンフランシスコ名前: Plagger ... utf8::encode($yaml2); is Dump($hash2), $yaml2, 'Dumping Japanese hash works'; is_deeply Load($yaml2), $hash2, 'Loading Japanese hash works'; PK��V�[R_�h��h��geo_construct.tnu��[��#!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 PK��V�[5��mn��n�� rfc2732.tnu��[��# 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] PK��V�[�y��geo_basic.tnu��[��#!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 PK��V�[�ola��mix.tnu��[��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"); PK��V�[�-F �� sq-brackets.tnu��[��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; PK��V�[�FT��geo_point.tnu��[��#!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 PK��V�[�\n�" ��" �� roytest5.htmlnu��[��<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> PK��V�[%��abs.tnu��[��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 PK��V�[$e��e�� escape-char.tnu��[��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; PK��V�[_k�n�� userpass.tnu��[��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; PK��V�[��\ ��\ ��mailto.tnu��[��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; PK��V�[>�� roytest4.htmlnu��[��<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> PK��V�[8y��rtsp.tnu��[��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"); PK��V�[!A��news.tnu��[��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); PK��V�[�!�G�� query-param.tnu��[��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'; PK��V�[�;�'��ipv6.tnu��[��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(); PK��V�["�L�� storable.tnu��[��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'); PK��V�[��5� �� ldap.tnu��[��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----"); PK��V�[��Q��Q��icap.tnu��[��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); PK��V�[u,�� old-file.tnu��[��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; } PK��V�[��$��$�� old-base.tnu��[��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"); } PK��V�[�2<�E��E�� roytest1.htmlnu��[��<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> PK��V�[ �� path-segments.tnu��[��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'; } PK��V�[��ftp.tnu��[��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"); PK��V�[��]�0��0��00-report-prereqs.ddnu��[��do { my $x = { 'configure' => { 'requires' => { 'ExtUtils::MakeMaker' => '6.78' } }, 'develop' => { 'requires' => { 'Test::Pod' => '1.41' } }, 'runtime' => { 'requires' => { 'List::Util' => '1.09', 'Scalar::Util' => '1.09', 'Test::Builder' => '0', 'Test::More' => '0.96', 'perl' => '5.012' } }, 'test' => { 'recommends' => { 'CPAN::Meta' => '2.120900' }, 'requires' => { 'ExtUtils::MakeMaker' => '0', 'File::Spec' => '0', 'Test::More' => '0.96', 'Test::Tester' => '0.107' } } }; $x; }PK��V�[]:y��escape.tnu��[��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; PK��V�[@b�����00-report-prereqs.tnu��[��#!perl use strict; use warnings; # This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.028 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 $mod eq 'perl'; next if grep { $_ eq $mod } @exclude; my $file = $mod; $file =~ s{::}{/}g; $file .= ".pm"; my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; my $want = $req_hash->{$phase}{$type}{$mod}; $want = "undef" unless defined $want; $want = "any" if !$want && $want == 0; my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; 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: PK��V�[��idna.tnu��[��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"; PK��V�[�� urn-isbn.tnu��[��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); PK��V�[̒�' �� urn-scheme-exceptions.tnu��[��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' ); } } PK��V�[�m��gopher.tnu��[��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"); PK��V�[d��2��scheme-exceptions.tnu��[��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; PK��V�[�I�K��K��clone.tnu��[��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"; PK��V�[�fB��rel.tnu��[��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"); PK��V�[ x�l��rsync.tnu��[��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'); PK��V�[�!��sip.tnu��[��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/')); PK��V�[�{BM<��<��pop.tnu��[��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'); PK��V�[�L�-U��U��sq-brackets-legacy.tnu��[��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; PK��V�[ʇ��heuristic.tnu��[��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"); } PK��V�[� �V+��+��mms.tnu��[��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"); PK��V�[Ǧ�� old-absconf.tnu��[��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"); PK��V�[�Cp(A��A��storable-test.plnu��[��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"); } PK��V�[.��split.tnu��[��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"; PK��V�[�W�-!��-!�� otpauth.tnu��[��#!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 PK��V�[(�}# �� data.tnu��[��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"); PK��V�[��`S��S��http.tnu��[��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); PK��V�[�;�� roy-test.tnu��[��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); } PK��V�[s\�<��<�� roytest2.htmlnu��[��<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> PK��V�[�� generic.tnu��[��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"); PK��V�[�36�� urn-oid.tnu��[��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); PK��V�[U��$ ��$ ��file.tnu��[��#!/usr/bin/perl -w #======================================================================== # # t/file.t # # AppConfig::File test file. # # Written by Andy Wardley <abw@cre.canon.co.uk> # # Copyright (C) 1998 Canon Research Centre Europe Ltd. # All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #------------------------------------------------------------------------ # # TODO # # test PEDANTIC option # # * test EXPAND_WARN option # #======================================================================== use strict; use vars qw($loaded); use lib qw( ../lib ./lib ); use Test::More tests => 43; use AppConfig qw(:expand :argcount); use AppConfig::File; ok(1); #------------------------------------------------------------------------ # create new AppConfig::State and AppConfig::File objects #------------------------------------------------------------------------ my $state = AppConfig::State->new({ CREATE => '^(?:define\|here)_', GLOBAL => { EXPAND => EXPAND_ALL, ARGCOUNT => ARGCOUNT_ONE, }, }, 'html', 'same', 'split', 'title', 'ident', 'cash' => { EXPAND => EXPAND_NONE }, # ignore '$' in cash 'hdir' => { EXPAND => EXPAND_VAR }, # expand only $vars 'verbose' => { ARGCOUNT => ARGCOUNT_NONE }, # simple flags.. 'cruft' => { ARGCOUNT => ARGCOUNT_NONE, DEFAULT => 1, }, 'debug' => { ARGCOUNT => ARGCOUNT_NONE, DEFAULT => 1, }, 'chance' => { ARGCOUNT => ARGCOUNT_NONE, DEFAULT => 1, }, 'hope' => { ARGCOUNT => ARGCOUNT_NONE, DEFAULT => 1, }, 'drink' => { ARGCOUNT => ARGCOUNT_LIST, }, 'name' => { ARGCOUNT => ARGCOUNT_HASH, }, 'here_empty' => { ARGCOUNT => ARGCOUNT_NONE, }, 'here_hash' => { ARGCOUNT => ARGCOUNT_HASH, }, ); # turn debugging on to trigger debugging in $cfgfile # $state->_debug(1); my $cfgfile = AppConfig::File->new($state); # AppConfig::State can be turned off, AppConfig::File debugging remains on. # $state->_debug(0); ok( defined $state, 'state defined' ); ok( defined $cfgfile, 'cfgfile defined' ); ok( $cfgfile->parse(\DATA), 'parsed' ); #------------------------------------------------------------------------ # test variable values got set with correct expansion #------------------------------------------------------------------------ # html has no embedded variables ok( $state->html() eq 'public_html' ); # cash should not* be expanded (EXPAND_NONE) to protect '$' ok( $state->cash() eq 'I won $200!' ); SKIP: { skip("User does not have a home directory", 2) unless defined $ENV{HOME}; # hdir expands variables ($html) but not uids (~) ok( $state->hdir() eq '~/public_html' ); # see if "[~/$html]" matches "[${HOME}/$html]". It may fail if your # platform doesn't provide getpwuid(). See AppConfig::Sys for details. my ($one, $two) = $state->same() =~ / \[ ( [^\]]+ ) \] \s+=>\s+ \[ ( [^\]]+ ) \]/gx; is( $one, $two, 'one is two' ); } # test that "split" came out the same as "same" is( $state->same(), $state->split(), 'same split' ); # test that "verbose" got set to 1 when no parameter was provided is( $state->verbose(), 1, 'verbose' ); # test that debug got turned off by explicit (debug = 0) ok( ! $state->debug(), 'not debuggin' ); # test that cruft got turned off by "nocruft" ok( ! $state->cruft(), 'not crufty' ); ok( $state->nocruft(), 'nocruft' ); # test that chance got turned on by "nochance = 0" ok( $state->chance(), 'there is a chance' ); ok( ! $state->nochance(), 'there is not no chance' ); # test that hope got turned on by "nohope = off" ok( $state->hope(), 'there is hope' ); ok( ! $state->nohope(), 'there is not no hope' ); # check auto-creation of variables and variable expansion of # [block] variable is( $state->define_user(), 'abw', 'user is abw'); is( $state->define_home(), '/home/abw', 'home is /home/abw' ); is( $state->define_chez(), '/chez/abw', 'chez is /chez/abw' ); is( $state->define_choz(), 'foo#bar', 'choz is set' ); is( $state->define_chuz(), '^#', 'chuz is set' ); #21 - #22: test $state->varlist() without strip option my (%set, $expect, $got); %set = $state->varlist('^define_'); $expect = 'define_chaz=/$chez/#chaz, define_chez=/chez/abw, define_choz=foo#bar, define_chuz=^#, define_home=/home/abw, define_user=abw'; $got = join(', ', map { "$_=$set{$_}" } sort keys %set); is( scalar keys %set, 6, 'five keys' ); is( $expect, $got, 'varlist' ); #23 - #24: test $state->varlist() with strip option %set = $state->varlist('^define_', 1); $expect = 'chaz=/$chez/#chaz, chez=/chez/abw, choz=foo#bar, chuz=^#, home=/home/abw, user=abw'; $got = join(', ', map { "$_=$set{$_}" } sort keys %set); is( scalar keys %set, 6, 'five stripped keys'); is( $expect, $got, 'stripped varlist' ); #25 - #27: test ARGCOUNT_LIST my $drink = $state->drink(); is( $drink->[0], 'coffee', 'coffee'); is( $drink->[1], 'beer', 'beer'); is( $drink->[2], 'water', 'water'); #28 - #31: test ARGCOUNT_HASH my $name = $state->name(); my $crew = join(", ", sort keys %$name); ok( $crew eq "abw, mim, mrp" ); ok( $name->{'abw'} eq 'Andy' ); ok( $name->{'mrp'} eq 'Martin' ); ok( $name->{'mim'} eq 'Man in the Moon' ); #32 - #33: test quoting ok( $state->title eq "Lord of the Rings"); ok( $state->ident eq "Keeper of the Scrolls"); # test \$ and \# suppression is( $state->define_chaz(), '/$chez/#chaz', 'chaz defined' ); # test whitespace required before '#' is( $state->define_choz(), 'foo#bar', 'choz defined' ); is( $state->define_chuz(), '^#', 'chuz defined' ); #39 - #42: test here-doc ok( ! $state->here_empty(), 'empty here-doc'); is( $state->here_linebreaks(), <<HERE, 'line breaks'); white spaces are preserved in here-doc, except the last linebreak. HERE is( $state->here_quote(), '<<NOT_A_HERE_DOC_if_in_quotes', 'heredoc in quotes'); is( $state->here_eof(), "parse() reads to eof if the boundary string is absent.\n", 'heredoc with EOF'); is_deeply( $state->here_hash(), { 'key1' => 'value 1', 'key2' => 'value 2', 'key3' => "multi-line\nvalue 3", '"key 4"' => "<<AA\n recursive here-doc not supported.\nAA", }, 'hash with here-doc values'); #======================================================================== # the rest of the file comprises the sample configuration information # that gets read by parse() #======================================================================== __DATA__ # lines starting with '#' are regarded as comments and are ignored html = public_html cash = I won $200! hdir = ~/$html same = [~/$html] => [${HOME}/$html] verbose debug = 0 nocruft # this next one should turn chance ON (equivalent to "chance = 1") nochance = 0 nohope = off # the next line has a continutation, but should be treated the same split = [~/$html] => \ [${HOME}/$html] # test list definitions drink coffee drink beer drink water # test hash definitions name abw = Andy name mrp = Martin name = mim = "Man in the Moon" # test quoting title = "Lord of the Rings" ident = 'Keeper of the Scrolls' [define] user = abw # this is a comment home = /home/$user chez = /chez/$define_user chaz = /\$chez/\#chaz # this is also a comment choz = foo#bar # this is a comment, but the '# bar' part wasn't chuz = ^# # so is this, nor was that [here] empty = <<BAR BAR linebreaks =<<'BAR' white spaces are preserved in here-doc, except the last linebreak. BAR quote ='<<NOT_A_HERE_DOC_if_in_quotes' hash = key1 =<<--- value 1 --- hash = key2= "value 2" # Putting hash keys in here doc is ugly, not recommended, but supported hash = <<--- key3 = multi-line value 3 --- hash = <<=== "key 4" = <<AA recursive here-doc not supported. AA === eof = <<--- parse() reads to eof if the boundary string is absent. PK��V�[��nn�� punycode.tnu��[��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); } PK��V�[KN�b��b��sort-hash-query-form.tnu��[��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; PK��V�[Ȇ�ð��cwd.tnu��[��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'); PK��V�[Y�� old-relbase.tnu��[��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"); PK��[���chmod.tnu��[��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: PK��[j�� symlinks.tnu��[��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: PK��[+U�Б�� recurse.tnu��[��use 5.006; use strict; use warnings; use Test::More 0.92; use File::Temp; use lib 't/lib'; use TestUtils qw/exception tempd has_symlinks/; use Path::Tiny; #--------------------------------------------------------------------------# subtest 'no symlinks' => sub { my $wd = tempd; my @tree = qw( aaaa.txt bbbb.txt cccc/dddd.txt cccc/eeee/ffff.txt gggg.txt ); my @breadth = qw( aaaa.txt bbbb.txt cccc gggg.txt cccc/dddd.txt cccc/eeee cccc/eeee/ffff.txt ); path($_)->touchpath for @tree; subtest 'iterator' => sub { my $iter = path(".")->iterator( { recurse => 1 } ); my @files; while ( my $f = $iter->() ) { push @files, "$f"; } is_deeply( [ sort @files ], [ sort @breadth ], "Breadth first iteration" ) or diag explain \@files; }; subtest 'visit' => sub { my @files; path(".")->visit( sub { push @files, "$_[0]" }, { recurse => 1 }, ); is_deeply( [ sort @files ], [ sort @breadth ], "Breadth first iteration" ) or diag explain \@files; }; subtest 'visit state' => sub { my $result = path(".")->visit( sub { $_[1]->{$_}++ }, { recurse => 1 }, ); is_deeply( [ sort keys %$result ], [ sort @breadth ], "Breadth first iteration" ) or diag explain $result; }; subtest 'visit abort' => sub { my $result = path(".")->visit( sub { return \0 if ++$_[1]->{count} == 2 }, { recurse => 1 } ); is( $result->{count}, 2, "visitor aborted on false scalar ref" ); }; }; subtest 'with symlinks' => sub { plan skip_all => "No symlink support" unless has_symlinks(); my $wd = tempd; my @tree = qw( aaaa.txt bbbb.txt cccc/dddd.txt cccc/eeee/ffff.txt gggg.txt ); my @follow = qw( aaaa.txt bbbb.txt cccc gggg.txt pppp qqqq.txt cccc/dddd.txt cccc/eeee cccc/eeee/ffff.txt pppp/ffff.txt ); my @nofollow = qw( aaaa.txt bbbb.txt cccc gggg.txt pppp qqqq.txt cccc/dddd.txt cccc/eeee cccc/eeee/ffff.txt ); path($_)->touchpath for @tree; symlink path( 'cccc', 'eeee' ), path('pppp'); symlink path('aaaa.txt'), path('qqqq.txt'); subtest 'no follow' => sub { # no-follow subtest 'iterator' => sub { my $iter = path(".")->iterator( { recurse => 1 } ); my @files; while ( my $f = $iter->() ) { push @files, "$f"; } is_deeply( [ sort @files ], [ sort @nofollow ], "Don't follow symlinks" ) or diag explain \@files; }; subtest 'visit' => sub { my @files; path(".")->visit( sub { push @files, "$_[0]" }, { recurse => 1 }, ); is_deeply( [ sort @files ], [ sort @nofollow ], "Don't follow symlinks" ) or diag explain \@files; }; }; subtest 'follow' => sub { subtest 'iterator' => sub { my $iter = path(".")->iterator( { recurse => 1, follow_symlinks => 1 } ); my @files; while ( my $f = $iter->() ) { push @files, "$f"; } is_deeply( [ sort @files ], [ sort @follow ], "Follow symlinks" ) or diag explain \@files; }; subtest 'visit' => sub { my @files; path(".") ->visit( sub { push @files, "$_[0]" }, { recurse => 1, follow_symlinks => 1 }, ); is_deeply( [ sort @files ], [ sort @follow ], "Follow symlinks" ) or diag explain \@files; }; }; }; 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 # PK��[P��K@��@��parent.tnu��[��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 # PK��[9��Y�� rel-abs.tnu��[��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 # PK��[,n& ��data/chmod.txtnu��[�� 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 PK��[XIF�p��p�� basename.tnu��[��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 # PK��[�X��8��8��fakelib/PerlIO/utf8_strict.pmnu��[��package PerlIO::utf8_strict; 0; # make require fail PK��[�#�2��2��fakelib/Unicode/UTF8.pmnu��[��package Unicode::UTF8; 0; # make require fail PK��[̠p��mutable_tree_while_iterating.tnu��[��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; PK��[�� U�� exports.tnu��[��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: PK��[�� subsumes.tnu��[��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 # PK��[�.B��mkdir.tnu��[��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 # PK��[��u�f��f��basic.tnu��[��use strict; use warnings; use Test::More tests => 7 + ($] < 5.013001 ? 1 : 0); use Test::Fatal qw(exception success); use Try::Tiny 0.07; like( exception { die "foo bar" }, qr{foo bar}, "foo bar is like foo bar", ); ok( ! exception { 1 }, "no fatality means no exception", ); try { die "die"; } catch { pass("we die on demand"); } success { fail("this should never be emitted"); }; try { # die "die"; } catch { fail("we did not demand to die"); } success { pass("a success block runs, passing"); }; { my $i = 0; try { die { foo => 42 }; } catch { 1; } success { fail("never get here"); } finally { $i++; pass("finally block after success block"); }; is($i, 1, "finally block after success block still runs"); }; # TODO: test for fatality of undef exception? { package BreakException; sub DESTROY { eval { my $x = 'o no'; } } } if ($] < 5.013001) { like( exception { exception { my $blackguard = bless {}, 'BreakException'; die "real exception"; } }, qr{false exception}, "we throw a new exception if the exception is false", ); } { package FalseObject; use overload 'bool' => sub { 0 }; } like( exception { exception { die(bless {} => 'FalseObject'); } }, qr{false exception}, "we throw a new exception if the exception is false", ); PK��[��A��digest.tnu��[��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 # PK��[�Fu�~��~�� locking.tnu��[��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; PK��[.=�BI��BI��input_output.tnu��[��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 # PK��[,x�� sig_die.tnu��[��use 5.008001; use strict; use warnings; use Test::More 0.96; use File::Temp qw(tmpnam); use Path::Tiny; use lib 't/fakelib'; 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"; } my $called_handler; { local $SIG{__DIE__} = sub { ++$called_handler }; $file->slurp_utf8; } ok !$called_handler, 'outer $SIG{__DIE__} handler should not be called'; unlink $file; done_testing; PK��[�G�e6��6��input_output_no_UU.tnu��[��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 # PK��[�q�� children.tnu��[��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 # PK��[�� size.tnu��[��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 # PK��[O�а\|��\|�� zzz-spec.tnu��[��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 # PK��[~�C�� overloading.tnu��[��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 # PK��[�?�ׂ��normalize.tnu��[��use 5.008001; use strict; use warnings; use Test::More 0.96; use lib 't/lib'; use TestUtils qw/exception/; use Path::Tiny; my @cases = ( #<<< [ '.' => '.' ], [ './' => '.' ], [ '/' => '/' ], [ '/.' => '/' ], [ '..' => '..' ], [ '/..' => '/' ], [ '../' => '..' ], [ '../..' => '../..' ], [ '/./' => '/' ], [ '/foo/' => '/foo' ], [ 'foo/' => 'foo' ], [ './foo' => 'foo' ], [ 'foo/.' => 'foo' ], #>>> ); for my $c (@cases) { my ( $in, $out ) = @$c; my $label = defined($in) ? $in : "undef"; $label = "empty" unless length $label; is( path($in)->stringify, $out, sprintf( "%5s -> %-5s", $label, $out ) ); } 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 # PK��[}��C��C��input_output_no_PU_UU.tnu��[��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 # PK��[W/gW��visit.tnu��[��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"; PK��[��-��mkpath.tnu��[��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 # PK��[M�~Z��exception.tnu��[��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: PK��[0;��zz-atomic.tnu��[��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(); PK��[kC��temp.tnu��[��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 # PK��[&.\[F7��F7��filesystem.tnu��[��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; PK��[��{N��N��lib/TestUtils.pmnu��[��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; PK��[k��READMEnu��[��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. PK��[%�Y�.��.��has_same_bytes.tnu��[��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 # PK��[�ϔv��01-base32hex.tnu��[��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(); PK��[�騌��00-base32.tnu��[��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(); PK��[�� Exporter.tnu��[��#!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'); PK��[a�I�+��+��warn.tnu��[��#!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"); } PK��[^��use.tnu��[�� 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" ); PK��[ْ@k��pod.tnu��[��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(); PK��[[+�.�� 35limit.tnu��[��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); PK��[��N�? ��? ��35prepare.tnu��[��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"); PK��[%�D�� 81procs.tnu��[��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(); PK��[qi�Q��$��rt61849-bind-param-buffer-overflow.tnu��[��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"; PK��[O0�f��40server_prepare_error.tnu��[��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(); PK��[,�N��N��71impdata.tnu��[��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"; PK��[��)#r��r��gh352.tnu��[��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 PK��[��51bind_type_guessing.tnu��[��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; PK��[a��92ssl_optional.tnu��[��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')); PK��[�.~��~��65segfault.tnu��[��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); PK��[�3c��rt83494-quotes-comments.tnu��[��# 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; PK��[�� 17quote.tnu��[��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; PK��[��i\|� �� rt75353-innodb-lock-timeout.tnu��[��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; PK��[��faP��P��53comment.tnu��[��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; PK��[��52comment.tnu��[��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; PK��[`;��rt88006-bit-prepare.tnu��[��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; PK��[D�=z��lib.plnu��[��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; PK��[0�i)��32insert_error.tnu��[��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(); PK��[�Hϥ��01caching_sha2_prime.tnu��[��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(); PK��[W C>��40bit.tnu��[��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; PK��[A:��92ssl_backronym_vulnerability.tnu��[��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')); PK��[�҅#� �� 80procs.tnu��[��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(); PK��[\l_j��j��76multi_statement.tnu��[��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(); PK��[�ܽѿ �� 40types.tnu��[��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(); PK��[[��< ��< ��40server_prepare.tnu��[��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(); PK��[�׹�� 57trackgtid.tnu��[��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(); PK��[\�#j��55utf8.tnu��[��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; } PK��[�.{Ǒ �� 70takeimp.tnu��[��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"); } PK��[�5"��!��99_bug_server_prepare_blob_null.tnu��[��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; PK��[�A�c��29warnings.tnu��[��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); PK��[$�t�� 41bindparam.tnu��[��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; PK��[�E:��rt110983-valid-mysqlfd.tnu��[��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'); PK��[�O�o�� 42bindparam.tnu��[��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; PK��[B�0�R��R�� rt91715.tnu��[��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"; } PK��[d��-��-��41blobs_prepare.tnu��[��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; PK��[�~�zz��z��00base.tnu��[��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"; PK��[ ��X��X�� 87async.tnu��[��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; PK��[�;{��92ssl_riddle_vulnerability.tnu��[��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')); PK��[9�n<��<�� 65types.tnu��[��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; PK��[Ÿ�^�� 40nulls.tnu��[��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; PK��[�F�,��40keyinfo.tnu��[��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; PK��[�>w�"��"�� manifest.tnu��[��BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release testing'); } } use Test::More; eval 'use Test::DistManifest'; if ($@) { plan skip_all => 'Test::DistManifest required to test MANIFEST'; } manifest_ok(); PK��[�-��75supported_sql.tnu��[��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; PK��[�pn��rt25389-bin-case.tnu��[��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 ); } } PK��[ùۖ�� version.tnu��[��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; PK��[��>qA��A��40bindparam2.tnu��[��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()); PK��[�� 60leaks.tnu��[��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; } PK��[�c �� 40bindparam.tnu��[��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; PK��[��+��85init_command.tnu��[��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(); PK��[�P-~��86_bug_36972.tnu��[��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(); PK��[�s)��rt86153-reconnect-fail-memory.tnu��[��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"; PK��[ �?��16dbi-get_info.tnu��[��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; PK��[Ӓ�>��mysql.mtestnu��[��{ 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; PK��[#�p�?��?��41int_min_max.tnu��[��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; } PK��[%�"��40server_prepare_crash.tnu��[��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(); PK��[�Ӆۆ�� 40blobs.tnu��[��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; PK��[^��J��J��gh360.tnu��[��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'); PK��[�k�w/��/�� 15reconnect.tnu��[��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"); } PK��[��Ɗ'��'��!��rt50304-column_info_parentheses.tnu��[��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; PK��[vẇd ��d ��10connect.tnu��[��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; PK��[��f~ ��~ �� 50commit.tnu��[��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"); PK��[�`ݙ��30insertfetch.tnu��[��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; PK��[%XR��rt118977-zerofill.tnu��[��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"; } PK��[�3�&��91errcheck.tnu��[��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; PK��[iFH�I ��I ��rt85919-fetch-lost-connection.tnu��[��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(); PK��[��~��56connattr.tnu��[��#!/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; PK��[�H�7 ��7 ��31insertid.tnu��[��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(); PK��[Nᨣ� �� 40nulls_prepare.tnu��[��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; PK��[��-��-��55utf8mb4.tnu��[��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; PK��[ ��)��)��40catalog.tnu��[��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(); PK��[j��89async-method-check.tnu��[��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; PK��[d�Z��40numrows.tnu��[��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; PK��[!��05dbcreate.tnu��[��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(); PK��[��&�9��9��50chopblanks.tnu��[��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; PK��[(��88async-multi-stmts.tnu��[��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; PK��[�"L��20createdrop.tnu��[��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(); PK��[e�%o/��/��99compression.tnu��[��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; PK��[�F&��25lockunlock.tnu��[��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"; PK��[��[��43count_params.tnu��[��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; PK��[�1�1��40listfields.tnu��[��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()); PK��[��\��render_xml.tnu��[��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 PK��[X�� render.yamlnu��[��name: Löver PK��[�!<S��render.jsonnu��[��{ "name" : "Löver" } PK��[�D�'.��.��release-pod-syntax.tnu��[��#!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(); PK��[ϵ��000-compile-modules.tnu��[��# 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; PK��[�@�s��template/signature.ttnu��[��Smööches, Ingy PK��[5��%=��=��template/letter.ttnu��[��Hi [% name %], Have a nice day. [% PROCESS signature.tt %] PK��[]-<�� render_json.tnu��[��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 PK��[p�[�� render_yaml.tnu��[��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 PK��[V�#��#�� render.xmlnu��[��<xml> <name>Löver</name> </xml> PK��[a�sB �� cli.tnu��[��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 PK��[�y0�� examples.tnu��[��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 # PK��[�94�(W��(W�� zzz-lwp.tnu��[��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 # PK��[c�:�� cookies_for.tnu��[��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 # PK��[�E�$��publicsuffix.tnu��[��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 # PK��[�>�� parse.tnu��[��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 # PK��[j`��sort.tnu��[��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 # PK��[W�Jiy��y��save.tnu��[��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: PK��[8�Dr"��r"��add.tnu��[��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 # PK��[K��I;��;��lib/MockTime.pmnu��[��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; PK��[�:�Oe��e�� 07_eval.tnu��[��#!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$_"; } PK��[e��N��N��10_bad_use.tnu��[��#!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'; } PK��[�jv�J��J��06_threads.tnu��[��#!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(); PK��[�� 04_test_funcs.tnu��[��#!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; PK��[�8�p��13_do.tnu�ȯ��#!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'; PK��[S��05_script.tnu��[��#!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++; } PK��[!̧�� 12_padstale.tnu��[��#!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'; PK��[�I�� 02_refs.tnu��[��#!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; PK��[y�� 03_count.tnu��[��#!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); PK��[�+��s��s��00_compile.tnu��Iw��use strict; use Test::More tests => 1; BEGIN { use_ok 'Test::Requires' } diag "Test::More: $Test::More::VERSION"; PK��[�Ʃ�� 01_info.tnu��[��#!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]; PK��[]�F'&��&��08_leaktrace.tnu��[��#!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'; }; PK��[i��6�� lib/foo.plnu�ȯ��1;PK��[��#��#�� 11_logfp.tnu��[��#!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'; PK��[��^��09_info_more.tnu��[��#!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 PK��[F�$��like-exception.tnu��[��#!/usr/bin/perl use strict; use Test::Builder::Tester tests => 6; use Test::Fatal qw( dies_ok lives_ok ); test_out( "ok 1 - died" ); dies_ok { die "FAIL" } 'died'; test_test( "die dies" ); test_out( "ok 1 - code should throw an exception" ); dies_ok { die "FAIL" }; test_test( "die dies (default description)" ); test_out( "not ok 1 - returned" ); test_fail( +2 ); test_err( "# expected an exception but none was raised" ); dies_ok { return 1 } 'returned'; test_test( "return doesn't die" ); test_out( "ok 1 - returned" ); lives_ok { return 1 } 'returned'; test_test( "return lived" ); test_out( "ok 1 - code should not throw an exception" ); lives_ok { return 1 }; test_test( "return lived (default description)" ); test_out( "not ok 1 - died" ); test_fail( +2 ); test_err( "# expected return but an exception was raised" ); lives_ok { die "FAIL" } 'died'; test_test( "die doesn't live" ); PK��[��ײ��todo.tnu�ȯ��#!/usr/bin/perl use strict; use Test::Builder::Tester tests => 4; use Test::More 0.65; use Test::Fatal; my $file = __FILE__; if (!eval { Test::Builder::Tester->VERSION(1.20) }) { # Test::More 0.96 my $builder = Test::Builder->new; no warnings 'redefine'; test_out = sub { Test::Builder::Tester::test_out(@_); $builder->todo_output($builder->output); } } { my $line = __LINE__ + 13; my $out = <<FAIL; not ok 1 - succeeded # TODO unimplemented # Failed (TODO) test 'succeeded' # at $file line $line. # got: '0' # expected: '1' ok 2 - no exceptions # TODO unimplemented FAIL chomp($out); test_out($out); { local $TODO = "unimplemented"; is(exception { is(0, 1, "succeeded") }, undef, "no exceptions"); } test_test( "\$TODO works" ); } { my $line = __LINE__ + 13; my $out = <<FAIL; not ok 1 - succeeded # TODO unimplemented # Failed (TODO) test 'succeeded' # at $file line $line. # got: '0' # expected: '1' ok 2 - no exceptions # TODO unimplemented FAIL chomp($out); test_out($out); { local $TODO = "unimplemented"; stuff_is_ok(0, 1); } test_test( "\$TODO works" ); sub stuff_is_ok { my ($got, $expected) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; is( exception { is($got, $expected, "succeeded") }, undef, "no exceptions" ); } } { my $line = __LINE__ + 13; my $out = <<FAIL; not ok 1 - succeeded # TODO unimplemented # Failed (TODO) test 'succeeded' # at $file line $line. # got: '0' # expected: '1' ok 2 - no exceptions # TODO unimplemented FAIL chomp($out); test_out($out); { local $TODO = "unimplemented"; stuff_is_ok2(0, 1); } test_test( "\$TODO works" ); sub stuff_is_ok2 { my ($got, $expected) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; _stuff_is_ok2(@_); } sub _stuff_is_ok2 { my ($got, $expected) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; is( exception { is($got, $expected, "succeeded") }, undef, "no exceptions" ); } } { my $line = __LINE__ + 14; my $out = <<FAIL; not ok 1 - succeeded # TODO unimplemented # Failed (TODO) test 'succeeded' # at $file line $line. # got: '0' # expected: '1' ok 2 - no exceptions # TODO unimplemented ok 3 - level 1 # TODO unimplemented FAIL chomp($out); test_out($out); { local $TODO = "unimplemented"; multi_level_ok(0, 1); } test_test( "\$TODO works" ); sub multi_level_ok { my ($got, $expected) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; is( exception { _multi_level_ok($got, $expected) }, undef, "level 1" ); } sub _multi_level_ok { my ($got, $expected) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; is( exception { is($got, $expected, "succeeded") }, undef, "no exceptions" ); } } PK��[J�6 �� find_missing.tnu��[��use strict; use warnings; use Test::More tests => 35 + 9; use Test::Needs (); use lib 't/lib'; _find_missing = \&Test::Needs::_find_missing; my $have_vpm = eval { require version }; for my $v ($] - 0.001, $], $] + 0.001) { my $fail = $v > $]; my @parts = sprintf('%.6f', $v) =~ /^(\d+)\.(\d{3})(\d{3})/; my $str_v = join '.', map $_+0, @parts; for my $c ( $v, qq["$str_v"], qq["v$str_v"], qq[v$str_v], qq[version->new("$str_v")] ) { SKIP: { skip "version.pm not available", 1 if !$have_vpm && $c =~ /version->/; my $check = eval $c or die $@; my $message = _find_missing({ perl => $check }); if ($fail) { is $message, sprintf("Need perl %.6f (have %.6f)", $v, $]), "perl prereq of $c failed"; } else { is $message, undef, "perl prereq of $c passed"; } } } } my $missing = "Module::Does::Not::Exist::".time; is _find_missing('ModuleWithVersion'), undef, 'existing module accepted'; is _find_missing({ 'ModuleWithVersion' => 1 }), undef, 'existing module with version accepted'; is _find_missing($missing), "Need $missing", 'missing module rejected'; is _find_missing({ $missing => 1 }), "Need $missing 1", 'missing module with version rejected'; is _find_missing({ 'ModuleWithVersion' => 2 }), "Need ModuleWithVersion 2 (have 1)", 'existing module with old version rejected'; is _find_missing([ $missing ]), "Need $missing", 'missing module rejected (arrayref)'; is _find_missing([ $missing => 1 ]), "Need $missing 1", 'missing module with version rejected (arrayref)'; eval { _find_missing('BrokenModule') }; like $@, qr/Compilation failed/, 'broken module dies'; eval { _find_missing('BrokenModule') }; like $@, qr/Compilation failed/, 'broken module dies again'; PK��[�Y輿��numify_version.tnu��[��use strict; use warnings; use Test::More; use Test::Needs (); my @try = ( [ '5' => '5.000000' ], [ 'v5' => '5.000000' ], [ '"5"' => '5.000000' ], [ '"v5"' => '5.000000' ], [ '5.008000' => '5.008000' ], [ '5.8.0' => '5.008000' ], [ 'v5.8.0' => '5.008000' ], [ '"5.8.0"' => '5.008000' ], [ '"v5.8.0"' => '5.008000' ], [ '5.010' => '5.010000' ], [ 'v5.10' => '5.010000' ], [ '"v5.10"' => '5.010000' ], [ '5.999000' => '5.999000' ], [ '5.999.0' => '5.999000' ], [ 'v5.999.0' => '5.999000' ], [ '"5.999.0"' => '5.999000' ], [ '"v5.999.0"' => '5.999000' ], [ '6' => '6.000000' ], [ 'v6' => '6.000000' ], [ '"6"' => '6.000000' ], [ '"v6"' => '6.000000' ], [ '6.999000' => '6.999000' ], [ '6.999.0' => '6.999000' ], [ 'v6.999.0' => '6.999000' ], [ '"6.999.0"' => '6.999000' ], [ '"v6.999.0"' => '6.999000' ], [ '7' => '7.000000' ], [ 'v7' => '7.000000' ], [ '"7"' => '7.000000' ], [ '"v7"' => '7.000000' ], [ '7.999000' => '7.999000' ], [ '7.999.0' => '7.999000' ], [ 'v7.999.0' => '7.999000' ], [ '"7.999.0"' => '7.999000' ], [ '"v7.999.0"' => '7.999000' ], ); plan tests => 1 + scalar @try; my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_; warn @_ }; for (@try) { my ($in, $want) = @$_; SKIP: { my $evaled = eval $in; skip "$in is unsupported syntax on perl $]", 1 if $@; my $got = Test::Needs::_numify_version($evaled); is $got, $want, sprintf "%10s parses correctly as %s", $in, $want; } } is scalar @warnings, 0, "no warnings"; PK��[Mv�Z��Z��standalone.tnu��[��use strict; use warnings; use lib 't/lib'; use TestAPI; TestAPI::test_api('standalone'); PK��[�1�e��e��test2.tnu��[��use strict; use warnings; use lib 't/lib'; use TestAPI; TestAPI::test_api('Test2' => 'Test2::API'); PK��[[��p��p��test-builder.tnu��[��use strict; use warnings; use lib 't/lib'; use TestAPI; TestAPI::test_api('Test::Builder' => 'Test::Builder'); PK��[}�j �� lib/TestAPI.pmnu��[��package TestAPI; use strict; use warnings; use Test::More; use IPC::Open3; use Config (); my @perl = $^X =~ /(.)/s; { my $taint; local $^W = 0; local $@; local $SIG{__DIE__}; local $SIG{__WARN__} = sub { $taint = 1; push @perl, '-t'; }; if (!eval { eval substr($ENV{PATH}, 0, 0); 1 }) { $taint = 1; push @perl, '-T'; } if ($taint) { $ENV{PATH} = '/'; delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'}; } } my %inc; { my $cmd = join ' ', map qq{"$_"}, @perl, '-le', 'print for @INC'; my @inc = `$cmd`; chomp @inc; @inc{@inc} = (); } my @need_inc; my $i = -1; push @need_inc, $INC[$i] while ++$i < @INC && !exists $inc{$INC[$i]}; my $inc_extension = qr/[\\\/]\Q$Config::Config{archname}\E\|[\\\/]\Q$Config::Config{version}\E(?:[\\\/]\Q$Config::Config{archname}\E)?/; my $bare; for my $path (@need_inc) { unless (defined $bare and $path =~ /\A\Q$bare\E$inc_extension\z/) { $bare = $path; push @perl, "-I$path"; } } push @perl, "-It/lib"; my $missing = "Module::Does::Not::Exist::".time; sub capture { my $pid = open3 my $stdin, my $stdout, undef, @_ or die "can't run @_: $!"; my $out = do { local $/; <$stdout> }; close $stdout; waitpid $pid, 0; my $exit = $?; $out =~ s{^Possible precedence issue with control flow operator at .Test/Builder\.pm.\n}{}; return wantarray ? ($exit, $out) : $exit; } BEGIN { note = sub { print '# '.join('', @_)."\n" } if !defined &note; } sub check { my ($load, $args, $match, $name) = @_; my ($label, @load) = @$load; my @args = ((map "--load=$_", @load), @$args); my ($exit, $out) = capture @perl, '-MTestScript' . (@args ? '='.join(',', @args) : ''); $name = "$label: $name"; my $want_exit; my $unmatch; if (ref $match eq 'HASH') { $want_exit = $match->{exit}; $unmatch = $match->{unmatch}; $match = $match->{match}; } $match = !defined $match ? [] : ref $match eq 'ARRAY' ? $match : [$match]; $unmatch = !defined $unmatch ? [] : ref $unmatch eq 'ARRAY' ? $unmatch : [$unmatch]; if (!is $exit == 0, !$want_exit, "$name - exit status") { ok 0, $name for 1, 0 .. $#$match, 0 .. $#$unmatch; diag "Exit status $exit\nOutput:\n$out"; return; } my $plan_count = () = $out =~ /^[0-9]+\.\.[0-9]+(?: \|$)/mg; if (!ok $plan_count <= 1, "$name - no excess plans") { ok 0, $name for 0 .. $#$match, 0 .. $#$unmatch; diag "Output:\n$out"; return; } for my $m (@$match) { like $out, $m, $name; } for my $um (@$unmatch) { unlike $out, $um, $name; } } sub test_api { my ($label, @load) = @_; local $ENV{RELEASE_TESTING}; delete $ENV{RELEASE_TESTING}; my @using = map { my ($e, $o) = capture @perl, "-m$_", "-eprint+$_->VERSION"; $e ? () : "$_ $o"; } @load; if (@using != @load) { plan skip_all => "$label not available"; return; } plan tests => ( 143 + 14 ) !!@load + (73 + 14); note "Checking against ".join(', ', @using)."\n" if @using; check([@_], [$missing], qr/^1\.\.0 # SKIP/i, 'Missing module SKIPs', ); check([@_], ['BrokenModule'], { match => qr/syntax error/, exit => 1 }, 'Broken module dies', ); check([@_], ['ModuleWithVersion'], qr/^(?!1\.\.0 # SKIP)/i, 'Working module runs', ); check([@_], ['ModuleWithVersion', 2], qr/^1\.\.0 # SKIP/i, 'Outdated module SKIPs', ); { local $ENV{RELEASE_TESTING} = 1; check([@_], [$missing], { match => qr/^not ok/m, exit => 1 }, 'Missing module fails with RELEASE_TESTING', ); check([@_], ['BrokenModule'], { match => qr/syntax error/, exit => 1 }, 'Broken module dies with RELEASE_TESTING', ); check([@_], ['ModuleWithVersion'], qr/^(?!1\.\.0 # SKIP)/i, 'Working module runs with RELEASE_TESTING', ); check([@_], ['ModuleWithVersion', 2], { match => qr/^not ok/m, unmatch => qr/Cleaning up the CONTEXT stack/, exit => 1 }, 'Outdated module fails with RELEASE_TESTING', ); } return unless @load; check([@_], [$missing, '--plan'], qr/# skip/, 'Missing module skips with plan', ); check([@_], [$missing, '--no_plan'], qr/# skip/, 'Missing module skips with no_plan', ); SKIP: { skip 'Test::More too old to run tests without plan', 3 if !Test::More->can('done_testing'); check([@_], [$missing, '--tests'], qr/# skip/, 'Missing module skips with tests', ); } check([@_], [$missing, '--plan', '--tests'], qr/# skip/, 'Missing module passes with plan and tests', ); check([@_], [$missing, '--no_plan', '--tests'], qr/# skip/, 'Missing module passes with no_plan and tests', ); SKIP: { skip 'Test::More too old to run subtests', 93 + 14 if !Test::More->can('subtest'); check([@_], [$missing, '--subtest'], qr/^ +1\.\.0 # SKIP/mi, 'Missing module skips in subtest', ); check([@_], ['BrokenModule', '--subtest'], { match => qr/syntax error/, exit => 1 }, 'Broken module dies in subtest', ); check([@_], ['ModuleWithVersion', '--subtest'], [ qr/^ +1\.\.(?!0 # SKIP)/mi, qr/^ok[^\n#]+(?!# skip)/m ], 'Working module runs in subtest', ); check([@_], ['ModuleWithVersion', 2, '--subtest'], qr/^ +1\.\.0 # SKIP/mi, 'Outdated module skips in subtest', ); check([@_], [$missing, '--subtest', '--plan'], qr/# skip/, 'Missing module skips with plan in subtest', ); check([@_], [$missing, '--subtest', '--no_plan'], qr/# skip/, 'Missing module skips with no_plan in subtest', ); check([@_], [$missing, '--subtest', '--tests'], qr/# skip/, 'Missing module skips with tests in subtest', ); check([@_], [$missing, '--subtest', '--plan', '--tests'], qr/# skip/, 'Missing module passes with plan and tests in subtest', ); check([@_], [$missing, '--subtest', '--no_plan', '--tests'], qr/# skip/, 'Missing module passes with no_plan and tests in subtest', ); local $ENV{RELEASE_TESTING} = 1; check([@_], [$missing, '--subtest'], { match => qr/^ +not ok/m, exit => 1 }, 'Missing module fails in subtest with RELEASE_TESTING', ); } } 1; PK��[��2��2��lib/ModuleWithVersion.pmnu��[��package ModuleWithVersion; our $VERSION = 1; 1; PK��[�bBG��lib/BrokenModule.pmnu��[��]; PK��[�5�9��9��lib/TestScript.pmnu��[��package TestScript; use strict; use warnings; use Test::Needs; sub plan; sub subtest; sub done_testing; sub ok; for my $sub (qw(plan ok subtest done_testing)) { no strict 'refs'; no warnings 'redefine'; $sub = sub { if (!$INC{'Test2/API.pm'}) { require Test::Builder; my $tb = Test::Builder->new; for my $install (qw(plan ok subtest done_testing)) { {$install} = sub { $tb->$install(@_); }; } } else { plan = sub { my $ctx = Test2::API::context(); $ctx->plan( $_[0] eq 'no_plan' ? (0, 'NO PLAN') : $_[0] eq 'tests' ? ($_[1]) : @_ ); $ctx->release; }; subtest = \&Test2::API::run_subtest; ok = sub { my $ctx = Test2::API::context(); $ctx->ok(@_); $ctx->release; }; done_testing = sub { my $ctx = Test2::API::context(); $ctx->done_testing; $ctx->release; }; } goto &$sub; }; } sub import { my $class = shift; my $opts = { map { /^--([^=])(?:=(.))?/ ? ($1 => $2\|\|1) : () } @_ }; my @args = grep !/^--/, @_; @args = @args == 1 ? @args : { @args }; if ($opts->{load}) { eval qq{ package main; use $opts->{load}; 1; } or die $@; } if ($opts->{subtest}) { plan tests => 1; subtest subtest => sub { do_test($opts, @args) }; } else { do_test($opts, @args); } exit 0; } sub do_test { my ($opts, @args) = @_; if ($opts->{plan}) { plan tests => 2; } elsif ($opts->{no_plan}) { plan 'no_plan'; } if ($opts->{tests}) { ok 1; } test_needs @args; plan tests => 2 unless $opts->{tests} \|\| $opts->{plan} \|\| $opts->{no_plan}; ok 1; ok 1 unless $opts->{tests}; done_testing if $opts->{tests} && !($opts->{plan} \|\| $opts->{no_plan}); } 1; PK��[�Z��found.tnu��[��use strict; # compatible use warnings BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } } use lib 't/lib'; use Capture::Tiny qw(capture); use Config; use File::Spec; use Test::More; eval "use Devel::CheckLib"; if($@ =~ /Couldn't find your C compiler/) { plan skip_all => "Couldn't find your C compiler"; } else { eval "use Helper qw/create_testlib/"; } my $debug = $ENV{DEVEL_CHECKLIB_DEBUG} \|\| 0; # compile a test library my $libdir = create_testlib("bazbam"); my @lib = $^O eq 'MSWin32' # if Win32 (not Cygwin) ... ? ( $Config{cc} =~ /(^\|^\w+ )bcc/ # FIXME - find a second Borland lib ? ('cc3250', 'cc3250') # ... Borland : ('msvcrt', 'kernel32') # ... otherwise assume Microsoft ) : qw(m c) # default to Unix-style ; # cases are strings to interpolate into the assert_lib call my @cases = ( qq/lib => '$lib[0]'/, qq/lib => '$lib[1]'/, qq/lib => ['$lib[0]', '$lib[1]']/, ); push @cases, qq{lib => 'bazbam', libpath => '$libdir'} if $libdir; plan tests => 2 * scalar @cases; for my $c ( @cases ) { my $error; my ($stdout, $stderr) = capture { eval "assert_lib(debug => $debug, $c)"; $error = $@; }; is($error, q{}, "$c") \|\| diag("\tSTDOUT: $stdout\n\tSTDERR: $stderr\n"); ok(check_lib(debug => $debug, eval($c)), "... and check_lib is true"); } PK��[�GV��not_found.tnu��[��use strict; # compatible use warnings BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } } use Test::More; use Config; my $debug = 0; eval "use Devel::CheckLib"; if($@ =~ /Couldn't find your C compiler/) { plan skip_all => "Couldn't find your C compiler"; } my $platform_lib = $^O eq 'MSWin32' # if Win32 (not Cygwin) ... ? ( $Config{cc} =~ /(^\|^\w+ )bcc/ ? 'cc3250' # ... Borland : 'msvcrt' # ... otherwise assume Microsoft ) : 'm' # default to Unix-style ; # Cases are AoH: { arg => $string, missing => $string } my @cases = ( { arg => qq{lib => 'foo'}, missing => ['foo'] }, { arg => qq{lib => [qw/$platform_lib foo/]}, missing => ['foo'] }, { arg => qq{lib => [qw/foo $platform_lib/]}, missing => ['foo'] }, { arg => qq{lib => [qw/foo bar/]}, missing => [qw/foo bar/] }, ); plan tests => 3 * @cases; for my $c ( @cases ) { eval "assert_lib(debug => $debug, $c->{arg})"; my $err = $@; ok ( $err, "died on '$c->{arg}'" ); my $miss_string = join(q{, }, map { qq{'$_'} } @{$c->{missing}} ); like ($err, "/^Can't link\/include C library ${miss_string}/ms", "missing $miss_string detected" ); ok(!check_lib(debug => $debug, eval($c->{arg})), "... and check_lib is false"); } PK��[D��W��flags.tnu��[��use strict; # compatible use warnings BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } } use lib 't/lib'; use Capture::Tiny qw(capture); use Config; use File::Spec; use Test::More; eval "use Devel::CheckLib"; if($@ =~ /Couldn't find your C compiler/) { plan skip_all => "Couldn't find your C compiler"; } my $libdir; eval "use Helper qw(create_testlib)"; unless($libdir = create_testlib("bazbam")) { plan skip_all => "Couldn't build a library to test against"; }; my($debug, $stdout, $stderr) = ($ENV{DEVEL_CHECKLIB_DEBUG} \|\| 0); sub diagout { diag "\tSTDOUT: $stdout\n\tSTDERR: $stderr\n" } my %common = ( debug => $debug, incpath => 't/inc', libpath => $libdir, lib => 'bazbam', header => 'headerfile.h', function => <<EOF); #ifdef FOO1234 return 0; #else return 1; #endif EOF my $error; ($stdout, $stderr) = capture { eval { assert_lib(%common, ccflags => '-DFOO1234') }; $error = $@; }; is($error, '', "ccflags ok") or diagout; ($stdout, $stderr) = capture { eval { assert_lib(%common) }; $error = $@; }; like($error, qr/wrong/i, "ccflags wrong") or diagout; done_testing; PK��[�\|�<��<��bad-single-word-compiler.tnu��[��# $Id: bad-single-word-compiler.t,v 1.2 2008/02/07 14:16:39 drhyde Exp $ use strict; BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } } use Test::More; plan tests => 1; use Config; BEGIN { eval 'use Mock::Config;'; warnings->unimport('redefine') if $] >= 5.006; unless (defined($ActivePerl::VERSION) && $Config{cc} =~ /\bgcc\b/) { if (!$Mock::Config::VERSION) { plan skip_all => "XSConfig is readonly" if $Config{usecperl} or exists &Config::KEYS; Config::STORE = sub { $_[0]->{$_[1]} = $_[2] } } } } if ($Mock::Config::VERSION) { Mock::Config->import(cc => "flibbertigibbet"); } elsif (defined($ActivePerl::VERSION) && $Config{cc} =~ /\bgcc\b/) { my $obj = tied %Config::Config; $obj->{cc} = "flibbertigibbet"; } else { eval { $Config{cc} = 'flibbertigibbet' }; } SKIP: { skip "Couldn't update %Config", 1 if $@ =~ /%Config::Config is read-only/; eval "use Devel::CheckLib"; ok($@ =~ /^Couldn't find your C compiler/, "Bad single-word compiler is not OK"); } PK��[ �}l�� dash-l-libs.tnu��[��use strict; # compatible use warnings BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } } use lib 't/lib'; use Capture::Tiny qw(capture); use Config; use File::Spec; use Test::More; my $debug = $ENV{DEVEL_CHECKLIB_DEBUG} \|\| 0; my $libdir; eval "use Devel::CheckLib"; if($@ =~ /Couldn't find your C compiler/) { plan skip_all => "Couldn't find your C compiler"; } eval "use Helper qw(create_testlib)"; if($libdir = create_testlib("bazbam")) { plan tests => 1; } else { plan skip_all => "Couldn't build a library to test against"; }; my $runtime = '-l'.( $^O eq 'MSWin32' # if Win32 (not Cygwin) ... ? ( $Config{cc} =~ /(^\|^\w+ )bcc/ ? 'cc3250' # ... Borland : 'msvcrt' # ... otherwise assume Microsoft ) : 'm' # default to Unix-style ); # my $runtime = $^O eq 'MSWin32' ? '-lmsvcrt' : '-lm'; my $args = qq{LIBS => '$runtime -lbazbam -L$libdir'}; my $error; my ($stdout, $stderr) = capture { eval "assert_lib(debug => $debug, $args)"; $error = $@; }; is($error, q{}, "$args") \|\| diag("\tSTDOUT: $stdout\n\tSTDERR: $stderr\n"); PK��[�Qg`��`�� headers.tnu��[��use strict; # compatible use warnings BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } } use lib 't/lib'; use Capture::Tiny qw(capture); use Config; use File::Spec; use Test::More; eval "use Devel::CheckLib"; if($@ =~ /Couldn't find your C compiler/) { plan skip_all => "Couldn't find your C compiler"; } my $debug = $ENV{DEVEL_CHECKLIB_DEBUG} \|\| 0; # cases are strings to interpolate into the assert_lib call my %failcases = ( qq{incpath => '.', header => 'headerfile.h'} => "Can't link/include", qq{INC => '-t/inc', header => 'headerfile.h'} => "INC argument badly-formed" ); my @passcases = ( qq{incpath => '.', header => 't/inc/headerfile.h'}, qq{incpath => [qw(t/inc)], header => 'headerfile.h'}, qq{INC => '-I. -It/inc', header => 'headerfile.h'} ); plan tests => scalar(keys %failcases) + scalar(@passcases); for my $c (keys %failcases) { my $error; my ($stdout, $stderr) = capture { eval "assert_lib(debug => $debug, $c)"; $error = $@; }; ok($error =~ /^$failcases{$c}/, "$c") \|\| diag("$@\n\tSTDOUT: $stdout\n\tSTDERR: $stderr\n"); } for my $c ( @passcases ) { my $error; my ($stdout, $stderr) = capture { eval "assert_lib(debug => $debug, $c)"; $error = $@; }; is($error, q{}, "$c") \|\| diag("\tSTDOUT: $stdout\n\tSTDERR: $stderr\n"); } PK��[��Տ �� custom-function.tnu��[��use strict; # compatible use warnings BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } } use lib 't/lib'; use Capture::Tiny qw(capture); use Config; use File::Spec; use Test::More; eval "use Devel::CheckLib"; if($@ =~ /Couldn't find your C compiler/) { plan skip_all => "Couldn't find your C compiler"; } my $libdir; eval "use Helper qw(create_testlib)"; unless($libdir = create_testlib("bazbam")) { plan skip_all => "Couldn't build a library to test against"; }; my $debug = $ENV{DEVEL_CHECKLIB_DEBUG} \|\| 0; # cases are strings to interpolate into the assert_lib call my %failcases = ( qq{ incpath => 't/inc', libpath => '$libdir', lib => 'bazbam', header => 'headerfile.h', # bar() doesn't exist function => 'bar();' } => 'Can\'t link/include', qq{ incpath => 't/inc', libpath => '$libdir', lib => 'bazbam', header => 'headerfile.h', # libversion returns wrong result function => 'foo();if(libversion() < 5) return 0; else return 1;' } => 'wrong result', ); my %passcases = ( qq{ incpath => 't/inc', libpath => '$libdir', lib => 'bazbam', header => 'headerfile.h', functionbody => 'foo(); return 0;' }, "function exists", qq{ incpath => 't/inc', libpath => '$libdir', lib => 'bazbam', header => 'headerfile.h', functionbody => 'if(libversion() > 5) return 0; else return 1;' }, "function returns right value", qq{ incpath => 't/inc', libpath => '$libdir', lib => 'bazbam', header => 'headerfile.h', functionbody => 'foo();if(libversion() > 5) return 0; else return 1;' }, "function exists and other function returns right value", ); plan tests => scalar(keys %failcases) + scalar(keys %passcases); for my $c (keys %failcases) { my $error; my ($stdout, $stderr) = capture { eval "assert_lib(debug => $debug, $c)"; $error = $@; }; ok($error =~ /^$failcases{$c}/, "failed to build: $failcases{$c}") \|\| diag("$c\n$@\n\tSTDOUT: $stdout\n\tSTDERR: $stderr\n"); } for my $c ( keys %passcases ) { my $error; my ($stdout, $stderr) = capture { eval "assert_lib(debug => $debug, $c)"; $error = $@; }; is($error, q{}, "$passcases{$c}") \|\| diag("\tSTDOUT: $stdout\n\tSTDERR: $stderr\n"); } PK��[��&��&��inc/headerfile.hnu��[��int foo(void); int libversion(void); PK��[t�;��;��cmdline-LIBS-INC.tnu��[��use strict; # compatible use warnings BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } } use lib 't/lib'; use Capture::Tiny qw(capture); use Config; use File::Spec; use Test::More; my($debug, $stdout, $stderr) = ($ENV{DEVEL_CHECKLIB_DEBUG} \|\| 0); my $libdir; eval "use Devel::CheckLib"; if($@ =~ /Couldn't find your C compiler/) { #' plan skip_all => "Couldn't find your C compiler"; } eval "use Helper qw(create_testlib)"; if($libdir = create_testlib("bazbam")) { plan tests => 3; } else { plan skip_all => "Couldn't build a library to test against"; }; my $runtime = '-l'.( $^O eq 'MSWin32' # if Win32 (not Cygwin) ... ? ( $Config{cc} =~ /(^\|^\w+ )bcc/ ? 'cc3250' # ... Borland : 'msvcrt' # ... otherwise assume Microsoft ) : 'm' # default to Unix-style ); my $rval = undef; my @args = (qq{LIBS=$runtime}); ($stdout, $stderr) = capture { $rval = system( $Config{perlpath}, '-Mblib', '-MDevel::CheckLib', '-e', "print @ARGV;assert_lib(debug => $debug)", @args ); }; ok($stderr eq '' && defined($rval) && $rval == 0, "linked OK: ".join(', ', @args)) \|\| diag("\tSTDOUT: $stdout\n\tSTDERR: $stderr\n"); $rval = undef; @args = map { "LIBS=$_" } ($runtime, '-lbazbam', "-L$libdir"); ($stdout, $stderr) = capture { $rval = system( $Config{perlpath}, '-Mblib', '-MDevel::CheckLib', '-e', "print @ARGV;assert_lib(debug => $debug)", @args ); }; ok($stderr eq '' && defined($rval) && $rval == 0, "linked OK: ".join(', ', @args)) \|\| diag("\tSTDOUT: $stdout\n\tSTDERR: $stderr\n"); $rval = undef; @args = (qq{"LIBS=$runtime -lbazbam -L$libdir"}); ($stdout, $stderr) = capture { $rval = system( $Config{perlpath}, '-Mblib', '-MDevel::CheckLib', '-e', "print @ARGV;assert_lib(debug => $debug)", @args ); }; ok($stderr eq '' && defined($rval) && $rval == 0, "linked OK: ".join(', ', @args)) \|\| diag("\tSTDOUT: $stdout\n\tSTDERR: $stderr\n"); PK��[2b��multi-word-compiler.tnu��[��# $Id: multi-word-compiler.t,v 1.3 2008/02/07 14:16:39 drhyde Exp $ use strict; BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } } use Test::More; plan tests => 1; use Config; BEGIN { eval 'use Mock::Config;'; warnings->unimport('redefine') if $] >= 5.006; unless(defined($ActivePerl::VERSION) && $Config{cc} =~ /\bgcc\b/) { if (!$Mock::Config::VERSION) { plan skip_all => "XSConfig is readonly" if $Config{usecperl} or exists &Config::KEYS; Config::STORE = sub { $_[0]->{$_[1]} = $_[2] } } } } my $fake_cc = qq{"$^X" $Config{cc}}; if ($Mock::Config::VERSION) { Mock::Config->import(cc => $fake_cc); } elsif (defined($ActivePerl::VERSION) && $Config{cc} =~ /\bgcc\b/) { my $obj = tied %Config::Config; $obj->{cc} = $fake_cc; } else { eval { $Config{cc} = $fake_cc; } } SKIP: { skip "Couldn't update %Config", 1 if $@ =~ /%Config::Config is read-only/; eval "use Devel::CheckLib"; is $@, "", "Good multi-word compiler is OK"; } PK��[�R�Z&��&��exit_with_message.tnu��[��use strict; # compatible use warnings BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } } use Test::More; use File::Temp; my $fh = File::Temp->new(); print {$fh} << 'ENDPRINT'; use Devel::CheckLib; check_lib_or_exit( qw/lib hlagh/ ); ENDPRINT $fh->close; my $err = `"$^X" $fh 2>&1`; if($err =~ /Couldn't find your C compiler/) { plan skip_all => "Couldn't find your C compiler"; } else { plan tests => 1; like ($err, "/^Can't link\\/include C library 'hlagh'/ms", "missing hlagh detected non-fatally" ); } PK��[sr�\6��6��analyze-binary.tnu��[��use strict; # compatible use warnings BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } } use lib 't/lib'; use Capture::Tiny qw(capture); use Config; use File::Spec; use Test::More; eval "use Devel::CheckLib"; if($@ =~ /Couldn't find your C compiler/) { plan skip_all => "Couldn't find your C compiler"; } my $libdir; eval "use Helper qw(create_testlib)"; unless($libdir = create_testlib("bazbam")) { plan skip_all => "Couldn't build a library to test against"; }; my($debug, $stdout, $stderr) = ($ENV{DEVEL_CHECKLIB_DEBUG} \|\| 0); sub diagout { diag "\tSTDOUT: $stdout\n\tSTDERR: $stderr\n" } sub analyze_binary { my ($lib, $bin, $expected_rc, @args) = @_; $bin = File::Spec->rel2abs($bin); system $bin, @args; warn "\$?: $?, expected: ".($expected_rc << 8)."\n"; return ($? == ($expected_rc << 8)); } my %common = ( debug => $debug, incpath => 't/inc', libpath => $libdir, lib => 'bazbam', header => 'headerfile.h', function => 'return (argc - 1);', ); my $error; ($stdout, $stderr) = capture { eval { assert_lib(%common, analyze_binary => sub { analyze_binary @_, 3, qw(foo bar doz) } ) }; $error = $@; }; is($error, '', "analyze_binary ok") or diagout; ($stdout, $stderr) = capture { eval { assert_lib(%common, analyze_binary => sub { analyze_binary @_, 3, qw(foo) } ) }; $error = $@; }; like($error, qr/wrong analysis/i, "analyze_binary wrong") or diagout; done_testing; PK��[$��݈��coverage.shnu�ȯ��#!/bin/sh # $Id: coverage.sh,v 1.1 2008/02/26 21:54:55 drhyde Exp $ cover -delete HARNESS_PERL_SWITCHES=-MDevel::Cover make test cover PK��[~�Y_�� 00-load.tnu��[��use strict; # compatible use warnings BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } } use Test::More tests => 1; eval "use Devel::CheckLib"; ok($@ =~ /Couldn't find your C compiler/ \|\| !$@, "Can load module"); PK��[k�� lib/Helper.pmnu��[��package Helper; use strict; # compatible use warnings BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } } use Config; use Cwd; use Exporter; use IO::File; use File::Spec::Functions qw/catfile canonpath splitdir/; use File::Temp qw/tempdir/; use vars qw/@EXPORT @ISA/; @ISA = qw/Exporter/; @EXPORT = qw( create_testlib find_compiler find_binary ); my $orig_wd = cwd; BEGIN { require Devel::CheckLib; } # for _quiet_system() sub _quiet_system { goto &Devel::CheckLib::_quiet_system; } #--------------------------------------------------------------------------# # create_testlib( 'bazbam' ) # # takes a library name and compiles a simple library with two functions, # foo() (which returns 0) and libversion() (which returns 42), in a temp # directory and returns the temp directory. Returns undef if something # went wrong #--------------------------------------------------------------------------# sub create_testlib { my ($libname) = (@_); return unless $libname; my $tempdir = tempdir(CLEANUP => 1, TEMPLATE => "Devel-Assert-testlib-XXXXXXXX"); chdir $tempdir; my $code_fh = IO::File->new("${libname}.c", ">"); print {$code_fh} "int libversion() { return 42; }\nint foo() { return 0; }\n"; $code_fh->close; my $cc = (split(/\s+/, $Config{cc}))[0]; my $gccv = $Config{gccversion}; my $rv = $cc eq 'gcc' ? _gcc_lib( $libname ) : $cc eq 'cc' ? _gcc_lib( $libname ) : $cc eq 'cl' ? _cl_lib( $libname ) : $gccv ? _gcc_lib( $libname ) : undef ; chdir $orig_wd; return $rv ? canonpath($tempdir) : undef; } sub _gcc_lib { my ($libname) = @_; my $cc = find_compiler() or return; my $ar = find_binary('ar') or return; my $ranlib = find_binary('ranlib') or return; my $ccflags = $Config{ccflags}; my $libfile = "lib${libname}.a"; _quiet_system(qq{"$cc" $ccflags -c ${libname}.c}) and return; _quiet_system($ar, 'rc', $libfile, "${libname}$Config{_o}") and return; _quiet_system($ranlib, $libfile) and return; return -f $libfile } sub _cl_lib { my ($libname) = @_; my $cc = find_compiler() or return; my $ar = find_binary('lib') or return; _quiet_system($cc, '/c', "${libname}.c") and return; _quiet_system($ar, "${libname}$Config{_o}") and return; return -f "${libname}.lib"; } #--------------------------------------------------------------------------# # find_binary, find_compiler # # Returns absolute path to an executable file in $ENV{PATH} or undef # if it can't be found. find_binary() takes a program argument; # find_compiler takes no arguments and just returns the path to $Config{cc} #--------------------------------------------------------------------------# sub find_binary { my ($program) = @_; if ($Config{_exe} && $program !~ /$Config{_exe}$/) { $program .= $Config{_exe}; } return $program if -x $program; my @search_paths = split /$Config{path_sep}/, $ENV{PATH}; my @lib_search_paths = map lib_to_bin($_), split /$Config{path_sep}/, $ENV{LIBRARY_PATH}\|\|''; for my $path ( @search_paths, @lib_search_paths ) { my $binary = catfile( $path, $program ); return $binary if -x $binary; } return; } sub lib_to_bin { my ( $lib_dir ) = @_; my @parts = splitdir $lib_dir; pop @parts; push @parts, 'bin'; my $bin_dir = catfile(@parts); return $bin_dir; } sub find_compiler { my $result = find_binary($Config{cc}); return $result if($result); # sometimes $Config{cc} isn't very clean eg it can be 'cc -q32' on AIX return find_binary((split(/\s+/, $Config{cc}))[0]) if($Config{cc} =~ /\s/); undef; } 1; # must be true PK��[�b��v4-split-list.tnu��[��use NetAddr::IP; # $Id: v4-split-list.t,v 1.1.1.1 2006/08/14 15:36:06 lem Exp $ my %addr = ( '10.0.0.10' => [ '255.255.252.0', 24, [ '10.0.0.0', '10.0.1.0', '10.0.2.0', '10.0.3.0' ]], '10.0.0.1' => [ '255.255.255.254', 32, [ '10.0.0.0', '10.0.0.1', ]], '10.0.0.2' => [ '255.255.255.255', 32, [ '10.0.0.2', ]], '10.0.0.3' => [ '255.255.255.252', 32, [ '10.0.0.0', '10.0.0.1', '10.0.0.2', '10.0.0.3', ]], ); my $count = $\| = 1; print "1..", (2 scalar keys %addr), "\n"; for my $a (keys %addr) { my $ip = new NetAddr::IP $a, $addr{$a}->[0]; my @r = $ip->split($addr{$a}->[1]); my @m = (); if (scalar @r == @{$addr{$a}->[2]}) { print "ok ", $count++, "\n"; } else { print "not ok ", $count++, " (number $a)\n"; } for my $r (@r) { push @m, grep { $_ eq $r->addr } @{$addr{$a}->[2]}; } if (scalar @m == scalar @r) { print "ok ", $count++, "\n"; } else { print "not ok ", $count++, " (match $a)\n"; print "split=", join(', ', (map { $_->addr } @r)), "\n"; print "match=", join(', ', @m), "\n"; } } PK��[`U�C��full.tnu��[��use Test::More; # $Id: short.t,v 1.1.1.1 2006/08/14 15:36:06 lem Exp $ my %cases = ( '127.1' => '0000:0000:0000:0000:0000:0000:127.0.0.1', '123.23.4.210' => '0000:0000:0000:0000:0000:0000:123.23.4.210', 'DEAD:BEEF::1' => 'dead:beef:0000:0000:0000:0000:0000:0001', '1:2:3:4:5:6:7:8' => '0001:0002:0003:0004:0005:0006:0007:0008', '1234:5678:90AB:CDEF:0123:4567:890A:BCDE' => '1234:5678:90ab:cdef:0123:4567:890a:bcde', ); my $tests = keys %cases; plan tests => 1 + $tests; SKIP: { use_ok('NetAddr::IP') or skip "Failed to load NetAddr::IP", $tests; for my $c (sort keys %cases) { my $ip = new NetAddr::IP $c; my $rv = lc $ip->full; is($rv, $cases{$c}, "full($c) returns $rv"); } } PK��[�v\|�� v4-compplus.tnu��[��use NetAddr::IP; # $Id: v4-compplus.t,v 1.1.1.1 2006/08/14 15:36:06 lem Exp $ $\| = 1; print "1..50\n"; my $count = 1; for my $bits (8 .. 32) { my $large = new NetAddr::IP '10.0.0.0/8'; my $small = new NetAddr::IP '10.0.0.0', $bits; my @c = NetAddr::IP::compact($large, $small); if (@c == 1) { print "ok $count\n"; } else { print "not ok $count\n"; } ++$count; if ($c[0]->cidr eq '10.0.0.0/8') { print "ok $count\n"; } else { print "not ok $count\n"; } ++$count; } PK��[�'R(:��:��v4-re.tnu��[��use Test::More; # $Id: v4-re.t,v 1.1.1.1 2006/08/14 15:36:06 lem Exp $ my @ips = qw! 10.11.12.13 10.11.12/24 10.11.0/27 !; plan tests => 299; die "# Cannot continue without NetAddr::IP\n" unless use_ok('NetAddr::IP'); my @addrs = map { new NetAddr::IP $_ } @ips; for my $a (@addrs) { isa_ok($a, 'NetAddr::IP'); my $re = $a->re; my $rx; eval { $rx = qr/$re/ }; diag "Compilation of the resulting regular expression failed: $@" unless ok(!$@, "Compilation of the resulting regular expression"); for (my $ip = $a->network; $ip < $a->broadcast && $a->masklen != 32; $ip ++) { ok($a->addr =~ m/$rx/, "Match of $ip in $a"); } ok($a->broadcast->addr =~ m/$rx/, "Match of broadcast of $a"); ok(NetAddr::IP->new('default') !~ m/$rx/, "0/0 does not match"); } PK��[�I�Y��Y�� masklen.tnu��[��use NetAddr::IP; # $Id: masklen.t,v 1.1.1.1 2006/08/14 15:36:06 lem Exp $ my @masks = 0 .. 32; $\| = 1; print '1..', scalar @masks, "\n"; my $count = 1; for my $m (@masks) { my $ip = new NetAddr::IP '10.0.0.1', $m; if ($ip->masklen == $m) { print "ok ", $count ++, "\n"; } else { print "not ok ", $count ++, "\n"; } } PK��[�h\+��full6.tnu��[��use Test::More; # $Id: short.t,v 1.1.1.1 2006/08/14 15:36:06 lem Exp $ my %cases = ( '127.1' => '0000:0000:0000:0000:0000:0000:7f00:0001', '123.23.4.210' => '0000:0000:0000:0000:0000:0000:7b17:04d2', 'DEAD:BEEF::1' => 'dead:beef:0000:0000:0000:0000:0000:0001', '1:2:3:4:5:6:7:8' => '0001:0002:0003:0004:0005:0006:0007:0008', '1234:5678:90AB:CDEF:0123:4567:890A:BCDE' => '1234:5678:90ab:cdef:0123:4567:890a:bcde', ); my $tests = keys %cases; plan tests => 1 + $tests; SKIP: { use_ok('NetAddr::IP') or skip "Failed to load NetAddr::IP", $tests; for my $c (sort keys %cases) { my $ip = new NetAddr::IP $c; my $rv = lc $ip->full6; is($rv, $cases{$c}, "full6($c ) returns $rv"); } } PK��[��,��,��new-store.tnu��[��# t/new-store.t - test new Storable related - methods use Test::More; my $tests = 7; plan tests => $tests; SKIP: { skip "Failed to use Storable, module not found", $tests unless eval {require Storable && use_ok("Storable", 'freeze', 'thaw')}; skip "Failed to use NetAddr::IP", $tests unless use_ok("NetAddr::IP"); my $oip = new NetAddr::IP "localhost"; my $nip; isa_ok($oip, 'NetAddr::IP', 'Correct return type'); my $serialized; eval { $serialized = freeze($oip) }; unless (ok(!$@, "Freezing")) { diag $@; } # diag "Result is '$serialized'"; eval { $nip = thaw($serialized) }; unless (ok(!$@, "Thawing")) { diag $@; } isa_ok($nip, 'NetAddr::IP', 'Recovered correct type'); is("$nip", "$oip", "New object eq original object"); } PK��["��v6-split-bulk.tnu��[��use Test::More; use NetAddr::IP; # $Id: v6-split-bulk.t,v 1.1.1.1 2006/08/14 15:36:06 lem Exp $ my @addr = ( [ 'dead:beef::1', 126, 127, 2 ], [ 'dead:beef::1', 127, 127, 1 ], [ 'dead:beef::1', 127, 128, 2 ], [ 'dead:beef::1', 128, 128, 1 ], [ 'dead:beef::1', 124, 128, 16 ], [ 'dead:beef::1', 124, 127, 8 ], ); plan tests => (scalar @addr); for my $a (@addr) { my $ip = new NetAddr::IP $a->[0], $a->[1]; my $r = $ip->splitref($a->[2]); is(@$r, $a->[3]); } PK��[�{\|��v4-compact.tnu��[��use NetAddr::IP qw(Compact); # $Id: v4-compact.t,v 1.1.1.1 2006/08/14 15:36:06 lem Exp $ my @r = ( [ '10.0.0.0', '255.255.255.0'], [ '11.0.0.0', '255.255.255.0'], [ '12.0.0.0', '255.255.255.0'], [ '20.0.0.0', '255.255.0.0'], [ '30.0.0.0', '255.255.0.0'], [ '40.0.0.0', '255.255.0.0'], ); $\| = 1; if (defined($ENV{LIGHTERIPTESTS}) and $ENV{LIGHTERIPTESTS} =~ /yes/i) { print "1..0 # Skipped: LIGHTERIPTESTS = yes\n"; exit 0; } print "1..9\n"; my @ips1; for my $ip ('10.0.0.0', '11.0.0.0', '12.0.0.0') { push @ips1, NetAddr::IP->new($ip, 24)->split(32); } for my $ip ('20.0.0.0', '30.0.0.0', '40.0.0.0') { push @ips1, NetAddr::IP->new($ip, 16)->split(28); } my @ips2; for my $num (0 .. 255) { push @ips2, NetAddr::IP->new("192.168.$num.0", 24); } my $ips2_compact = '192.168.0.0/16'; # Compact(@) # compact_ips1_check(1, Compact(@ips1)); compact_ips2_check(2, Compact(@ips2)); # ->compact(@) # compact_ips1_check(3, $ips1[0]->compact(@ips1[1..$#ips1])); compact_ips2_check(4, $ips2[0]->compact(@ips2[1..$#ips2])); # Compact([]) # compact_ips1_check(5, @{Compact(\@ips1)}); compact_ips2_check(6, @{Compact(\@ips2)}); # ->compactref([]) # compact_ips1_check(7, @{$ips1[0]->compactref([@ips1[1..$#ips1]])}); compact_ips2_check(8, @{$ips2[0]->compactref([@ips2[1..$#ips2]])}); # duplicate IP # @ips1 = (); for my $ip (qw(1.1.1.1 1.1.1.1 1.1.1.1 1.1.1.1)) { push(@ips1, NetAddr::IP->new($ip)); } @c = NetAddr::IP::compact(@ips1); if (@c == 1 and $c[0]->cidr() eq '1.1.1.1/32') { print "ok 9\n"; } else { print "not ok 9\n"; } ###################################################################### sub compact_ips1_check { my $num = shift; my @ips = shift; my @mips; for my $ip (@ips) { push @mips, grep { $ip->addr eq $_->[0] and $ip->mask eq $_->[1] } @r; } if (@mips == @ips) { print "ok $num\n"; } else { print "not ok $num\n"; } } ###################################################################### sub compact_ips2_check { my $num = shift; my @ips = shift; if (@ips == 1 and $ips[0] eq $ips2_compact) { print "ok $num\n"; } else { print "not ok $num\n"; } } PK��[X��constants.tnu��[�� #use diagnostics; use Test::More tests => 15; use NetAddr::IP qw(Zeros Zero Ones V4mask V4net); my %const = ( '0::' => Zeros, '::' => Zero, 'FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF' => Ones, 'FFFF:FFFF:FFFF:FFFF:FFFF:FFFF::' => V4mask, '::FFFF:FFFF' => V4net, ); my($ip,$rv); foreach (sort keys %const) { ok(($ip = new NetAddr::IP($_)),"netaddr $_"); ok($ip->{addr} eq $const{$_},"match $_"); ok(($rv = length($const{$_})) == 16, "length $_ is $rv"); } PK��[yz�]��short.tnu��[��use Test::More; # $Id: short.t,v 1.1.1.1 2006/08/14 15:36:06 lem Exp $ my %cases = qw( 127.1 127.0.0.1 127.0.1.1 127.0.1.1 127.1.0.1 127.1.0.1 DEAD:BEEF::1 dead:beef::1 ::1 0:0::1 2001:620:600::1 2001:620:600::1 2001:620:600:0:1::1 2001:620:600:0:1::1 2001:620:601:0:1::1 2001:620:601::1:0:0:1 0:0:33:44::CC:DD 0:0:33:44:0:0:CC:DD 0:0:33:44::DD 0:0:33:44:0:0:0:DD 0:0:33:44:AA:: 0:0:33:44:AA:0:0:0 0:0:33::BB:0:0 0:0:33:0:0:BB:0:0 0:22:33:44:0:BB:CC:0 0:22:33:44:0:BB:CC:0 0:22:33:44:0:BB:CC:DD 0:22:33:44:0:BB:CC:DD 0:22:33:44:AA:BB:CC:0 0:22:33:44:AA:BB:CC:0 0:22:33:44:AA:BB:CC:DD 0:22:33:44:AA:BB:CC:DD 110:0:0:44:AA:: 110:0:0:44:AA:0:0:0 11:0:33:44:0:BB:CC:DD 11:0:33:44:0:BB:CC:DD 11:0:33:44:AA:BB:CC:DD 11:0:33:44:AA:BB:CC:DD 11:22:0:44:AA::DD 11:22:0:44:AA:0:0:DD 11:22:33:0:AA:BB:CC:0 11:22:33:0:AA:BB:CC:0 11:22:33:44:AA:: 11:22:33:44:AA:0:0:0 11:22::CC:DD 11:22:0:0:0:0:CC:DD 11::44:AA:0:0:DD 11:0:0:44:AA:0:0:DD 11::44:AA:BB:0:0 11:0:0:44:AA:BB:0:0 11::AA:0:0:DD 11:0:0:0:AA:0:0:DD 11::AA:BB:0:0 11:0:0:0:AA:BB:0:0 1:: 1:0:0:0:0:0:0:0 :: 0:0:0:0:0:0:0:0 ::33:44:AA:BB:0:0 0:0:33:44:AA:BB:0:0 ::44:0:0:CC:DD 0:0:0:44:0:0:CC:DD ::44:AA:BB:0:0 0:0:0:44:AA:BB:0:0 ::44:AA:BB:CC:DD 0:0:0:44:AA:BB:CC:DD ::A 0:0:0:0:0:0:0:A ); my $tests = 2 * keys %cases; plan tests => 1 + $tests; SKIP: { use_ok('NetAddr::IP') or skip "Failed to load NetAddr::IP", $tests; for my $c (sort keys %cases) { my $ip = new NetAddr::IP $cases{$c}; isa_ok($ip, 'NetAddr::IP', "$cases{$c}"); my $short = uc $ip->short; unless (is($short, $c, "short($cases{$c}) returns $short")) { diag "ip=$ip"; } } } PK��[>��C"��"�� wildcard.tnu��[��use NetAddr::IP; my @addr = ( [ 'localhost', '0.0.0.0' ], [ '10.0.0.0/24', '0.0.0.255' ], [ '192.168.0.0/16', '0.0.255.255' ], [ '10.128.0.1/17', '0.0.127.255' ] ); $\| = 1; print "1..", 2 * scalar @addr, "\n"; my $count = 1; for my $a (@addr) { my $ip = new NetAddr::IP $a->[0]; if ($ip->wildcard eq $a->[1]) { print "ok $count\n"; } else { print "not ok $count\n"; } ++$count; if (($ip->wildcard)[1] eq $a->[1]) { print "ok $count\n"; } else { print "not ok $count\n"; } ++$count; } PK��[��r�s��s�� rfc3021.tnu��[��use NetAddr::IP; $\| = 1; print '1..4', "\n"; my $test = 1; my $ip = new NetAddr::IP('192.168.1.8/31'); my @hosts = $ip->hostenum; print scalar(@hosts)," found where none expected\nnot " if @hosts; print "ok ",$test++,"\n"; NetAddr::IP::import qw(:rfc3021); @hosts = $ip->hostenum; print scalar(@hosts)," found where 2 expected\nnot " unless @hosts == 2; print "ok ",$test++,"\n"; print "got: $hosts[0], exp: 192.168.1.8/32\nnot " unless "$hosts[0]" eq '192.168.1.8/32'; print "ok ",$test++,"\n"; print "got: $hosts[1], exp: 192.168.1.9/32\nnot " unless "$hosts[1]" eq '192.168.1.9/32'; print "ok ",$test++,"\n"; PK��[3��v6-re.tnu��[��#use diagnostics; use Test::More; use NetAddr::IP; use NetAddr::IP::Util qw(addconst); my @ips = qw! ::0:0f00 ::FF:1e10 ::ffFF:2d20 ::eFF:3c30 ::eeFF:4b40 ::FF:5a50 ::FF:6960 ::FF:7870 ::FF:8780 ::FF:9690 ::FF:a5a0 ::FF:b4b0 ::FF:c3c0 ::FF:d2d0 ::FF:e1e0 ::FF:f0f0 !; my @mask = qw! 127 126 125 124 123 122 121 120 !; if (defined($ENV{LIGHTERIPTESTS}) and $ENV{LIGHTERIPTESTS} =~ /yes/i) { pop @mask; pop @mask; } my $tests = 0; my @addrs; foreach(@mask) { foreach my $ip (@ips) { push @addrs, new NetAddr::IP($ip,$_); } $tests += ((2*(128 - $_)) @ips) } $tests += (5 * @ips * @mask); plan tests => $tests; for my $a (@addrs) { isa_ok($a, 'NetAddr::IP'); my $re = $a->re6; my $rx; eval { $rx = qr/$re/ }; diag "Compilation of the resulting regular expression failed: $@" unless ok(!$@, "Compilation of the resulting regular expression"); for (my $ip = $a->network; $ip < $a->broadcast && $a->masklen != 128; $ip ++) { ok($a->addr =~ m/$rx/, "Match of $ip in $a"); } ok($a->broadcast->addr =~ m/$rx/, "Match of broadcast of $a"); my $under = $a->network->copy; $under->{addr} = (addconst($under->{addr},-1))[1]; my $over = $a->broadcast->copy; $over->{addr} = (addconst($over->{addr},1))[1]; ok($under !~ m/$rx/, "$under does not match"); ok($over !~ m/$rx/, "$over does not match"); ok(NetAddr::IP->new('::') !~ m/$rx/, ":: does not match"); } PK��[��b��canon.tnu��[��use Test::More; my %cases = ( '127.1' => '127.0.0.1', 'DEAD:BEEF::1' => 'dead:beef::1', '1234:5678:90AB:CDEF:0123:4567:890A:BCDE' => '1234:5678:90ab:cdef:123:4567:890a:bcde', ); my $tests = keys %cases; plan tests => 1 + $tests; SKIP: { use_ok('NetAddr::IP') or skip "Failed to load NetAddr::IP", $tests; for my $c (sort keys %cases) { my $ip = new NetAddr::IP $c; my $rv = $ip->canon; is($rv, $cases{$c}, "canon($c ) returns $rv"); } } PK��[<%�� v4-coalesce.tnu��[��use Test::More; if (defined($ENV{LIGHTERIPTESTS}) and $ENV{LIGHTERIPTESTS} =~ /yes/i) { print "1..0 # Skipped: LIGHTERIPTESTS = yes\n"; exit 0; } plan tests => 21; die "# Cannot continue without NetAddr::IP\n" unless use_ok('NetAddr::IP', 'Coalesce'); # Test a rather large set... my @ips = (); for my $o (0 .. 255) { push @ips, new NetAddr::IP "10.0.$o.1"; push @ips, new NetAddr::IP "10.0.$o.10"; push @ips, new NetAddr::IP "10.0.$o.100"; } sub tst { # This should return the empty list... my $r = Coalesce(24, 4, @ips); diag "Coalesce returned $r" unless isa_ok($r, 'ARRAY', 'Return type from Coalesce'); is(@$r, 0, "Empty array returned as expected"); # This should produce a list with all the /24s $r = Coalesce(24, 2, @ips); diag "Coalesce returned $r" unless isa_ok($r, 'ARRAY', 'Return type from Coalesce'); is(@$r, 256, "Whole result set as expected"); my @c = NetAddr::IP::Compact(@$r); is(@c, 1, "Results are compactable"); ok($c[0] eq '10.0.0.0/16', "Correct results"); # This should produce the same result as before, with an added /23 $r = Coalesce(24, 2, @ips, NetAddr::IP->new('10.0.0.125/23')); diag "Coalesce returned $r" unless isa_ok($r, 'ARRAY', 'Return type from Coalesce'); ok((grep { $_ eq '10.0.0.0/23' } @$r), "/23 went through"); @c = NetAddr::IP::Compact(@$r); is(@c, 1, "Results are compactable"); ok($c[0] eq '10.0.0.0/16', "Correct results"); } tst(); import NetAddr::IP qw(:old_nth); tst(); PK��[�eAyi��i��imhoff.tnu��[��#!/usr/bin/perl # This code was provided by Brent Imhoff and adapted to become a real test. # What this excercises, is that ::compact() should provide the same result # without caring about the order of its arguments. -lem use strict; #use warnings; use Test::More tests => 3; use NetAddr::IP qw(Compact); my @temp = <DATA>; my @sortreg = sort @temp; my @sortdec = sort { $b cmp $a} @temp; my @sortnum = sort { $a cmp $b} @temp; my $sortnum = Compact(map { NetAddr::IP->new($_) } @sortnum); my $sorttag = Compact(map { NetAddr::IP->new($_) } @sortreg); my $sortdec = Compact(map { NetAddr::IP->new($_) } @sortdec); is($sortnum, $sorttag); is($sortnum, $sortdec); is($sortdec, $sorttag); # I know this one is redundant __END__ 205.170.190.0/24 216.175.9.0/24 205.170.188.0/24 206.175.9.0/24 205.170.0.0/20 205.170.0.0/19 205.170.0.0/18 205.170.0.0/17 205.170.0.0/16 PK��[��v4-sprefix.tnu��[��use NetAddr::IP; # $Id: v4-sprefix.t,v 1.1.1.1 2006/08/14 15:36:06 lem Exp $ my @addr = ( [ '10.', '10.0.0.0/8' ], [ '11.11.', '11.11.0.0/16' ], [ '12.12.12.', '12.12.12.0/24' ], [ '13.13.13.13', '13.13.13.13/32' ], ); $\| = 1; print "1..", (3 * scalar @addr), "\n"; my $count = 1; for my $a (@addr) { my $ip = new NetAddr::IP $a->[0]; if ($ip->cidr eq $a->[1]) { print "ok $count\n"; } else { print "not ok $count\n"; } ++ $count; my $p = new NetAddr::IP $ip->cidr; if ($p->prefix eq $a->[0]) { print "ok $count\n"; } else { print "not ok $count\n"; } ++ $count; if ($p->nprefix eq $a->[0]) { print "ok $count\n"; } else { print "not ok $count\n"; } ++ $count; } PK��[�i�<��loops.tnu��[��# $Id: loops.t,v 1.2 2006/08/16 19:17:01 lem Exp $ use Test::More; my @deltas = (0, 1, 2, 3, 255); plan tests => 16 + @deltas; use_ok('NetAddr::IP'); my $count = 1; for (my $ip = new NetAddr::IP '10.0.0.1/28'; $ip < $ip->broadcast; $ip ++) { my $o = $ip->addr; $o =~ s/^.+\.(\d+)$/$1/; is($o, $count, "Correct octet for " . $ip); ++ $count; } my $ip = new NetAddr::IP '10.0.0.255/24'; $ip ++; is($ip, '10.0.0.0/24', "Correct mask wraparound"); $ip = new NetAddr::IP '10.0.0.0/24'; for my $v (@deltas) { my $target = '10.0.0.' . $v . '/24'; is($ip + $v, '10.0.0.' . $v . '/24', "$ip + $v vs $target"); } PK��[Q�#�� v4-hostenum.tnu��[��use NetAddr::IP; # $Id: v4-hostenum.t,v 1.1.1.1 2006/08/14 15:36:06 lem Exp $ my %addr = ( '10.0.0.0' => [ '255.255.255.252', [ '10.0.0.1', '10.0.0.2', ]], '11.0.0.0' => [ '255.255.255.255', [ '11.0.0.0', ]], '12.0.0.0' => [ '255.255.255.0', []], ); for my $o (1..254) { push @{$addr{'12.0.0.0'}->[1]}, '12.0.0.' . $o; } my $count = $\| = 1; print "1..", (2 * scalar keys %addr), "\n"; for my $a (keys %addr) { my $ip = new NetAddr::IP $a, $addr{$a}->[0]; my @r = $ip->hostenum; my @m = (); if (scalar @r == @{$addr{$a}->[1]}) { print "ok ", $count++, "\n"; } else { print "not ok ", $count++, " (number $a)\n"; } for my $r (@r) { push @m, grep { $_ eq $r->addr } @{$addr{$a}->[1]}; } if (scalar @m == scalar @r) { print "ok ", $count++, "\n"; } else { print "not ok ", $count++, " (match $a)\n"; print "henum=", join(', ', (map { $_->addr } @r)), "\n"; print "match=", join(', ', @m), "\n"; } } PK��[]s�� splitref.tnu��[�� use Test::More qw(no_plan); #tests => 28; use_ok('NetAddr::IP'); my $ip = new NetAddr::IP('ffff:a123:b345:c789::/48'); my $rv; ok(($rv = sprintf("%s",$ip)) eq 'FFFF:A123:B345:C789:0:0:0:0/48',"$rv eq FFFF:A123:B345:C789:0:0:0:0/48"); my $nets = $ip->splitref(48); ok($nets,'there is a net'); ok(@$nets == 1,'one item net'); ok(($rv = sprintf("%s",$ip)) eq 'FFFF:A123:B345:C789:0:0:0:0/48',"$rv eq FFFF:A123:B345:C789:0:0:0:0/48"); $nets = $ip->splitref(49,50); ok($nets,'there are nets'); ok(($rv = @$nets) == 3,"$rv is 3 item net"); my @exp = qw( FFFF:A123:B345:0:0:0:0:0/49 FFFF:A123:B345:8000:0:0:0:0/50 FFFF:A123:B345:C000:0:0:0:0/50 ); foreach(0..$#{$nets}) { ok(($rv = sprintf("%s",$nets->[$_])) eq $exp[$_], "$rv eq $exp[$_]"); } PK��[��ǂ��lower.tnu��[�� #use diagnostics; use Test::More tests => 2; use_ok ('NetAddr::IP', qw(:lower)); my $exp = 'ff:0:0:0:0:0:0:eeaa/128'; my $ip = new NetAddr::IP('FF::eeAA'); my $got = sprintf $ip; ok ($got eq $exp,"lower case $got"); PK��[�6��v4-splitplan.tnu��[�� use Test::More tests => 28; use_ok('NetAddr::IP'); my $ip = new NetAddr::IP('192.168.21.13/15'); my $rv; ok(($rv = sprintf("%s",$ip)) eq '192.168.21.13/15',"$rv eq 192.168.21.13/15"); my($plan,$masks) = $ip->_splitplan(15); ok($plan,'there is a plan'); ok(!$masks,'plan returns the orignal net'); ok(@$plan == 1,'one item plan'); ok(($rv = $plan->[0]) == 15,"plan $rv is original cidr 15"); my $cmask = new NetAddr::IP('255.126.0.0'); ok(($rv = sprintf("%s",$cmask)) eq '255.126.0.0/32',"$rv eq 255.126.0.0/32"); ($plan,$masks) = $ip->_splitplan($cmask); ok(!$plan,'failing because of bits in mask'); $cmask = new NetAddr::IP('255.254.0.0'); ok(($rv = sprintf("%s",$cmask)) eq '255.254.0.0/32',"$rv eq 255.254.0.0/32"); ($plan,$masks) = $ip->_splitplan($cmask); ok($plan,'there is a plan'); ok(!$masks,'plan returns the orignal net'); ok(@$plan == 1,'one item plan'); ok(($rv = $plan->[0]) == 15,"plan $rv is original cidr 15"); $cmask = '255.254.0.0'; # ipV4 text cmask ($plan,$masks) = $ip->_splitplan($cmask); ok($plan,'there is a plan'); ok(!$masks,'plan returns the orignal net'); ok(@$plan == 1,'one item plan'); ok(($rv = $plan->[0]) == 15,"plan $rv is original cidr 15"); $cmask = '255.126.0.0'; # ipV4 text cmask ($plan,$masks) = $ip->_splitplan($cmask); ok(!$plan,'failing because of bits in mask'); $cmask = 'garbage'; ($plan,$masks) = $ip->_splitplan($cmask); ok(!$plan,'failing because of garbage'); $cmask = 14; # cidr is bigger than requested ($plan,$masks) = $ip->_splitplan($cmask); ok(!$plan,'failing because of 15 overange'); # cidr makes more nets than 216 ($plan,$masks) = $ip->_splitplan(32); ok(!$plan,'failing to many nets 32 - 15 = 217'); ($plan,$masks) = $ip->_splitplan(16,16,16); ok(!$plan,'failing because of 3 * 16 overange'); # test for plan that just fits ($plan,$masks) = $ip->_splitplan(31); ok($plan,'there is a plan 31'); ok($masks,'plan has masks'); ok(($rv = @{$plan}) == 2 ** 16,"$rv should = 65536"); # set netlimit internal to 4 nets $NetAddr::IP::_netlimit = 4; ($plan,$masks) = $ip->_splitplan(17); # should fit ok($plan,"plan of 4 17's"); ($plan,$masks) = $ip->_splitplan(17,17,17,17,18); ok(!plan,"fail plan of 4 17's + 18"); ($plan,$masks) = $ip->_splitplan(18); ok(!plan,"fail plan of 8 18's"); PK��[�+�� over-arr.tnu��[��use NetAddr::IP; use Test::More; my @addr = ( [ '10.0.0.0/24', '10.0.0.1/32' ], [ '192.168.0.0/24', '192.168.0.1/32' ], [ '127.0.0.1/32', '127.0.0.1/32' ] ); $\| = 1; $tests = @addr; plan tests => $tests; SKIP: { skip "overload dereferencing not supported in version $] of Perl", $tests, unless ($overload::ops{dereferencing} && $overload::ops{dereferencing} =~ /\@\{\}/); for my $a (@addr) { my $ip = new NetAddr::IP $a->[0]; ok(@$ip[0]->cidr eq $a->[1],$a->[0]); } }; PK��[2 � �� over-qq.tnu��[��use NetAddr::IP; # $Id: over-qq.t,v 1.1.1.1 2006/08/14 15:36:06 lem Exp $ my @addr = ('10.0.0.0/8', '192.168.0.0/16', '127.0.0.1/32'); $\| = 1; print "1..", 5 * scalar @addr, "\n"; my $count = 1; for my $a (@addr) { my $ip = new NetAddr::IP $a; if ($a eq "$ip") { print "ok $count\n"; } else { print "not ok $count\n"; } ++ $count; if ($a eq $ip) { print "ok $count\n"; } else { print "not ok $count\n"; } ++ $count; if ($ip eq $a) { print "ok $count\n"; } else { print "not ok $count\n"; } ++ $count; if ($ip eq $ip) { print "ok $count\n"; } else { print "not ok $count\n"; } ++ $count; if ($ip == $ip) { print "ok $count\n"; } else { print "not ok $count\n"; } ++ $count; } PK��[e��relops.tnu��[��use NetAddr::IP; BEGIN { @gt = ( [ '255.255.255.255/32', '0.0.0.0/0' ], [ 'ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff', '::/0' ], [ '10.0.1.0/16', '10.0.0.1/24' ], [ '10.0.0.1/24', '10.0.0.0/24' ], [ 'deaf:beef::1/64', 'dead:beef::/64' ], ); @ngt = ( [ '0.0.0.0/0', '255.255.255.255/32' ], [ '::/0', 'ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff' ], [ '10.0.0.0/24', '10.0.0.0/24' ], [ 'dead:beef::/60', 'dead:beef::/60' ], ); @cmp = ( [ '0.0.0.0/0', '255.255.255.255/32', -1 ], [ '::/0', 'ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff', -1 ], [ '10.0.0.0/16', '10.0.0.0/8', 1 ], [ 'dead:beef::/60', 'dead:beef::/40', 1 ], [ '10.0.0.0/24', '10.0.0.0/8', 1 ], [ '255.255.255.255/32', '0.0.0.0/0', 1 ], [ 'ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff', '::/0', 1 ], [ '142.52.5.87', '142.52.2.88', 1 ], [ '10.0.0.0/24', '10.0.0.0/24', 0 ], [ 'default', 'default', 0 ], [ 'broadcast', 'broadcast', 0], [ 'loopback', 'loopback', 0], ); }; use Test::More tests => @gt + @ngt + (2 * @cmp); for my $a (@gt) { $a_ip = new NetAddr::IP::Lite $a->[0]; $b_ip = new NetAddr::IP::Lite $a->[1]; ok($a_ip > $b_ip, "$a_ip > $b_ip"); } for my $a (@ngt) { $a_ip = new NetAddr::IP::Lite $a->[0]; $b_ip = new NetAddr::IP::Lite $a->[1]; ok(!($a_ip > $b_ip), "$a_ip !> $b_ip"); } for $a (@cmp) { $a_ip = new NetAddr::IP::Lite $a->[0]; $b_ip = new NetAddr::IP::Lite $a->[1]; is($a_ip <=> $b_ip, $a->[2], "$a_ip <=> $b_ip is $a->[2]"); is($a_ip cmp $b_ip, $a->[2], "$a_ip cmp $b_ip is $a->[2]"); } PK��[Y��&e ��e ��v6-splitplan.tnu��[�� use Test::More tests => 28; use_ok('NetAddr::IP'); my $ip = new NetAddr::IP('ffff:a123:b345:c789::/48'); my $rv; ok(($rv = sprintf("%s",$ip)) eq 'FFFF:A123:B345:C789:0:0:0:0/48',"$rv eq FFFF:A123:B345:C789:0:0:0:0/48"); my($plan,$masks) = $ip->_splitplan(48); ok($plan,'there is a plan'); ok(!$masks,'plan returns the orignal net'); ok(@$plan == 1,'one item plan'); ok(($rv = $plan->[0]) == 48,"plan $rv is original cidr 48"); my $cmask = new NetAddr::IP('ffff:7fff:ffff:ffff::'); ok(($rv = sprintf("%s",$cmask)) eq 'FFFF:7FFF:FFFF:FFFF:0:0:0:0/128',"$rv eq FFFF:7FFF:FFFF:FFFF:0:0:0:0/128"); ($plan,$masks) = $ip->_splitplan($cmask); ok(!$plan,'failing because of bits in mask'); $cmask = new NetAddr::IP('FFFF:fFFF:FFFF::'); ok(($rv = sprintf("%s",$cmask)) eq 'FFFF:FFFF:FFFF:0:0:0:0:0/128',"$rv eq FFFF:fFFF:FFFF:0:0:0:0:0/128"); ($plan,$masks) = $ip->_splitplan($cmask); ok($plan,'there is a plan'); ok(!$masks,'plan returns the orignal net'); ok(@$plan == 1,'one item plan'); ok(($rv = $plan->[0]) == 48,"plan $rv is original cidr 48"); $cmask = 'FFFF:FFFF:FFFF::'; # ipV6 text cmask ($plan,$masks) = $ip->_splitplan($cmask); ok($plan,'there is a plan'); ok(!$masks,'plan returns the orignal net'); ok(@$plan == 1,'one item plan'); ok(($rv = $plan->[0]) == 48,"plan $rv is original cidr 48"); $cmask = 'FFFF:FFF:FFFF::'; # ipV6 text cmask ($plan,$masks) = $ip->_splitplan($cmask); ok(!$plan,'failing because of bits in mask'); $cmask = 'garbage'; ($plan,$masks) = $ip->_splitplan($cmask); ok(!$plan,'failing because of garbage'); $cmask = 47; # cidr is bigger than requested ($plan,$masks) = $ip->_splitplan($cmask); ok(!$plan,'failing because of 47 overange'); # cidr makes more nets than 216 ($plan,$masks) = $ip->_splitplan(65); ok(!$plan,'failing to many nets 65-48 = 217'); ($plan,$masks) = $ip->_splitplan(49,49,49); ok(!$plan,'failing because of 3 * 49 overange'); # test for plan that just fits ($plan,$masks) = $ip->_splitplan(64); ok($plan,'there is a plan 64'); ok($masks,'plan has masks'); ok(($rv = @{$plan}) == 2 ** 16,"$rv should = 65536"); # set netlimit internal to 4 nets $NetAddr::IP::_netlimit = 4; ($plan,$masks) = $ip->_splitplan(50); # should fit ok($plan,"plan of 4 50's"); ($plan,$masks) = $ip->_splitplan(50,50,50,50,51); ok(!plan,"fail plan of 4 50's + 51"); ($plan,$masks) = $ip->_splitplan(51); ok(!plan,"fail plan of 8 51's"); PK��[�� nofqdn.tnu��[�� use NetAddr::IP; $\| = 1; print "1..1\n"; my $test = 1; sub ok() { print 'ok ',$test++,"\n"; } my $ip = new NetAddr::IP('arin.net'); if (defined $ip) { print "ok $test # Skipped, resolved $ip\n"; $test++; } else { print "ok $test # Skipped, resolver not working\n"; $test++; } #import NetAddr::IP qw(:nofqdn); # #$ip = new NetAddr::IP('arin.net'); #print "unexpected response with :nofqdn\nnot " # if defined $ip; #&ok; PK��[��I��I��old-store.tnu��[��# t/old-store.t - test backwards compatible Storable interaction use Test::More; my $tests = 7; plan tests => $tests; SKIP: { skip "Failed to use Storable, module not found", $tests unless eval { require Storable && use_ok("Storable", 'freeze', 'thaw')}; skip "Failed to use NetAddr::IP", $tests unless use_ok("NetAddr::IP", ':old_storable'); my $oip = new NetAddr::IP "localhost"; my $nip; isa_ok($oip, 'NetAddr::IP', 'Correct return type'); my $serialized; eval { $serialized = freeze($oip) }; unless (ok(!$@, "Freezing")) { diag $@; } # diag "Result is '$serialized'"; eval { $nip = thaw($serialized) }; unless (ok(!$@, "Thawing")) { diag $@; } isa_ok($nip, 'NetAddr::IP', 'Recovered correct type'); is("$nip", "$oip", "New object eq original object"); } PK��[Ƅd��v4-xprefix.tnu��[��use NetAddr::IP; # $Id: v4-xprefix.t,v 1.1.1.1 2006/08/14 15:36:06 lem Exp $ my @addr = ( [ '0.0.0.0/1', '0-127' ], [ '128.0.0.0/1', '128-255' ], [ '0.0.0.0/2', '0-63' ], [ '128.0.0.0/2', '128-191' ], [ '10.128.0.0/17', '10.128.0-127.' ] ); $\| = 1; print "1..", (2 * scalar @addr), "\n"; my $count = 1; for my $a (@addr) { my $ip = new NetAddr::IP $a->[0]; # print "$a->[0] is ", $ip->prefix, "\n"; if ($ip->prefix eq $a->[1]) { print "ok $count\n"; } else { print "not ok $count\n"; } ++ $count; my $p = new NetAddr::IP $ip->prefix; # print $ip->prefix, " is $p\n"; if ($p->cidr eq $a->[0]) { print "ok $count\n"; } else { print "not ok $count\n"; } ++ $count; } PK��[�s�#��#��v4-split-bulk.tnu��[��use Test::More; use NetAddr::IP; # $Id: v4-split-bulk.t,v 1.1.1.1 2006/08/14 15:36:06 lem Exp $ my @addr = ( [ '10.0.0.0', 20, 32, 4096 ], [ '10.0.0.0', 22, 32, 1024 ], [ '10.0.0.0', 22, 24, 4 ], [ '10.0.0.0', 22, 23, 2 ], [ '10.0.0.0', 24, 32, 256 ], [ '10.0.0.0', 19, 32, 8192 ], [ '10.0.0.0', 24, 24, 1 ], [ '10.0.0.0', 31, 32, 2 ] ); plan tests => (scalar @addr); for my $a (@addr) { my $ip = new NetAddr::IP $a->[0], $a->[1]; my $r = $ip->splitref($a->[2]); is(@$r, $a->[3]); } PK��[h�Q��full6-uri.tnu��[��use Test::More; # $Id: short.t,v 1.1.1.1 2006/08/14 15:36:06 lem Exp $ my %cases = ( '127.1' => '0000:0000:0000:0000:0000:0000:7f00:0001', '123.23.4.210' => '0000:0000:0000:0000:0000:0000:7b17:04d2', '[DEAD:BEEF::1]' => 'dead:beef:0000:0000:0000:0000:0000:0001', '[1:2:3:4:5:6:7:8]' => '0001:0002:0003:0004:0005:0006:0007:0008', '[1234:5678:90AB:CDEF:0123:4567:890A:BCDE]' => '1234:5678:90ab:cdef:0123:4567:890a:bcde', ); my $tests = keys %cases; plan tests => 1 + $tests; SKIP: { use_ok('NetAddr::IP') or skip "Failed to load NetAddr::IP", $tests; for my $c (sort keys %cases) { my $ip = new NetAddr::IP $c; my $rv = lc $ip->full6; is($rv, $cases{$c}, "full6($c ) returns $rv"); } } PK��[��~��~��regexp.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; my $xism = qr/x/=~/\(\?\^/ ? "^" : "-xism"; { my $str = "ferg"; my $re = qr/$str/; check_test( sub { cmp_deeply("fergal", re($re)); }, { actual_ok => 1, diag => "", }, "re eq" ); check_test( sub { cmp_deeply("fergal", regexponly($re)); }, { actual_ok => 1, diag => "", }, "regexponly eq" ); check_test( sub { cmp_deeply("feargal", re($re)); }, { actual_ok => 0, diag => <<EOM, Using Regexp on \$data got : 'feargal' expect : $re EOM }, "re not eq" ); check_test( sub { cmp_deeply("feargal", regexponly($re)); }, { actual_ok => 0, diag => <<EOM, Using Regexp on \$data got : 'feargal' expect : $re EOM }, "regexponly not eq" ); check_test( sub { cmp_deeply("fergal", re($str)); }, { actual_ok => 1, diag => "", }, "string re eq" ); check_test( sub { cmp_deeply("feargal", re($str)); }, { actual_ok => 0, diag => <<EOM, Using Regexp on \$data got : 'feargal' expect : $re EOM }, "string runre not eq" ); } { my $re = qr/([ac])/; check_test( sub { cmp_deeply("abc", re($re, [qw( a )])); }, { actual_ok => 1, diag => "", }, "matches re eq" ); check_test( sub { cmp_deeply("abc", re($re, [qw( a c )], "g")); }, { actual_ok => 1, diag => "", }, "matches global re eq" ); check_test( sub { cmp_deeply("abc", re($re, [qw( a b )], "g")); }, { actual_ok => 0, diag => <<EOM, Compared [\$data =~ (?$xism:([ac]))]->[1] got : 'c' expect : 'b' EOM }, "matches global not eq" ); } { my $re = qr/(..)/; check_test( sub { cmp_deeply("abababcdcdefef", re($re, set(qw( ab cd ef )), "g")); }, { actual_ok => 1, diag => "", }, "matches re and set eq" ); check_test( sub { cmp_deeply("cat=2,dog=67,sheep=3,goat=2,dog=5", re(qr/(\D+)=\d+,?/, set(qw( cat sheep dog )), "g")) }, { actual_ok => 0, diag => <<EOM, Comparing [\$data =~ (?$xism:(\\D+)=\\d+,?)] as a Set Extra: 'goat' EOM }, "string runre not eq" ); } { require Over; my $o = Over->new("hi mom"); is("$o", "hi mom", "we make a stringifiable object"); check_test( sub { cmp_deeply($o, re(qr/mom/)); }, { actual_ok => 1 }, "re() tests objects via overloading", ); # Remember, Regexp stringification changes over time. -- rjbs, 2016-09-08 my $re = qr/dad/; my $re_str = "$re"; check_test( sub { cmp_deeply($o, re($re)); }, { actual_ok => 0, diag => <<EOM, Using Regexp on \$data got : 'hi mom' (instance of Over) expect : $re_str EOM }, "re() tests objects via overloading", ); } PK��[�1[��boolean-jsonpp.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests; local $YAML::XS::Boolean = "JSON::PP"; my $yaml = <<'...'; --- boolfalse: false booltrue: true stringfalse: 'false' stringtrue: 'true' ... my $hash = eval { Load $yaml }; if ($@ and $@ =~ m{JSON/PP}) { plan skip_all => "JSON::PP not installed"; exit; } plan tests => 7; isa_ok($hash->{booltrue}, 'JSON::PP::Boolean'); isa_ok($hash->{boolfalse}, 'JSON::PP::Boolean'); cmp_ok($hash->{booltrue}, '==', 1, "boolean true is true"); cmp_ok($hash->{boolfalse}, '==', 0, "boolean false is false"); ok(! ref $hash->{stringtrue}, "string 'true' stays string"); ok(! ref $hash->{stringfalse}, "string 'false' stays string"); my $yaml2 = Dump($hash); cmp_ok($yaml2, 'eq', $yaml, "Roundtrip booleans ok"); PK��[�9��duplicate-keys.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests; plan tests => 3; my $yaml = <<'...'; key: value key: another value ... my $hash = Load $yaml; is_deeply $hash, { key => 'another value' }, 'Allow duplicate keys (default)'; $YAML::XS::ForbidDuplicateKeys = 0; $hash = Load $yaml; is_deeply $hash, { key => 'another value' }, 'Allow duplicate keys explicitly'; $YAML::XS::ForbidDuplicateKeys = 1; $hash = eval { Load $yaml }; my $err = $@; like $err, qr{Duplicate key 'key'}, 'Forbid duplicate keys'; PK��[�B�`\��\��native.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 1; my $yaml = <<"..."; --- bar: \xC3\x83\xC2\xB6 foo: \xC3\xB6 ... my $hash = { foo => "\xF6", # LATIN SMALL LETTER O WITH DIAERESIS U+00F6 bar => "\xC3\xB6" # LATIN SMALL LETTER O WITH DIAERESIS U+00F6 (UTF-8) }; is Dump($hash), $yaml, 'Dumping native characters works'; PK��[p�hk��000-require-modules.tnu��[��# 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; ok eval("require $_; 1"), "require $_;$@"; } find { wanted => \&test, no_chdir => 1, }, 'lib'; done_testing; PK��[��wȯ�� boolean.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; use Test::Deep qw(true false); { check_tests( sub { cmp_deeply(1, bool(1), "num 1"); cmp_deeply(1, true, "num 1"); cmp_deeply("abds", bool(1), "string"); cmp_deeply("abds", true, "string"); cmp_deeply(0, bool(0), "num 0"); cmp_deeply(0, false, "num 0"); cmp_deeply("", bool(0), "string"); cmp_deeply("", false, "string"); cmp_deeply(undef, bool(0), "undef"); cmp_deeply(undef, false, "undef"); }, [ ({ actual_ok => 1, diag => "", }) x 10 ], "ok" ); check_tests( sub { cmp_deeply(1, bool(0), "num 1"); cmp_deeply(1, false, "num 1"); cmp_deeply("abds", bool(0), "string"); cmp_deeply("abds", false, "string"); cmp_deeply(0, bool(1), "num 0"); cmp_deeply(0, true, "num 0"); cmp_deeply("", bool(1), "string"); cmp_deeply("", true, "string"); }, [ ({ actual_ok => 0, diag => <<EOM, Comparing \$data as a boolean got : true ('1') expect : false ('0') EOM }) x 2, ({ actual_ok => 0, }) x 6, ], "string not eq" ); } PK��[�̑� �� blessed.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { my $b = bless [], "class"; check_test( sub { cmp_deeply($b, blessed("class")); }, { actual_ok => 1, diag => '', }, "Same" ); check_test( sub { cmp_deeply($b, blessed("other")); }, { actual_ok => 0, diag => <<EOM, Compared blessed(\$data) got : 'class' expect : 'other' EOM }, "Same" ); } { check_test( sub { cmp_deeply([], blessed()); }, { actual_ok => 1, diag => '', }, "Same" ); check_test( sub { cmp_deeply([], blessed("class")); }, { actual_ok => 0, diag => <<EOM, Compared blessed(\$data) got : undef expect : 'class' EOM }, "Same" ); } PK��[�El~��empty.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 5; is Dump(), '', 'Dumping no objects produces an empty yaml stream'; { my @objects = Load(''); is scalar(@objects), 0, 'Loading empty yaml stream produces no objects'; } { my @objects = Load("\n\n\n"); is scalar(@objects), 0, 'Loading yaml stream of empty lines produces no objects'; } { my @objects = Load(" \n \n \n"); is scalar(@objects), 0, 'Loading yaml stream of blank lines produces no objects'; } { my @objects = Load(<<'...'); # A comment line # Another comment after a blank line ... is scalar(@objects), 0, 'Loading blank lines an comments produce no objects'; } PK��[h��glob.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 2; no warnings 'once'; $main::G1 = "Hello"; is Dump(G1), <<'...', "Dump a scalar glob"; --- !!perl/glob NAME: G1 PACKAGE: main SCALAR: Hello ... eval '@main::G1 = (1..3)'; is Dump(G1), <<'...', "Add an array to the glob"; --- !!perl/glob ARRAY: - 1 - 2 - 3 NAME: G1 PACKAGE: main SCALAR: Hello ... exit; eval '@main::G1 = (1..3)'; my $g = G1; is Dump(\$g), <<'...', "Ref to glob"; --- !!perl/ref =: !!perl/glob ... my $array = [\$g, \$g, \G1]; is Dump($array), <<'...', "Globs and aliases"; --- - &1 !!perl/glob ARRAY: - 1 - 2 - 3 NAME: G1 PACKAGE: main SCALAR: Hello - 1 ... PK��["�2�� pl_sv_undef.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAML tests => 8; use YAML::XS qw(Dump Load); my $data = { foo => undef }; foreach my $t_data ( $data, Load(Dump($data)) ) { ok( exists($t_data->{foo}), "foo exists" ); is( $t_data->{foo}, undef, "value is undef" ); ok( eval { my $x = \$t_data->{foo}; 1 }, "can reference foo without error" ); is_deeply($t_data, $data, "is deeply"); } PK��[��٣��data/basic.ymlnu��[��# Data is in a Perl .t file so vim Test::Base hilighters work... # __DATA__ === Very Simple List +++ yaml --- - one - two +++ perl [ "one", "two" ] +++ libyaml_emit --- - one - two === List in List +++ yaml --- - one - - two - three - [four, five] +++ perl [ "one", [ "two", "three" ], [ "four", "five" ] ] +++ libyaml_emit --- - one - - two - three - - four - five === Very Simple Hash +++ yaml --- one: two +++ perl { "one" => "two" } +++ libyaml_emit --- one: two === Parse a more complicated structure +++ yaml --- - one - two - foo bar: [blah: {1: 2}, xxx] la la: mama - three +++ perl [ "one", "two", { "foo bar" => [ { "blah" => { 1 => 2, }, }, "xxx", ], "la la" => "mama", }, "three", ] === JSON is YAML +++ yaml {"name": "ingy", "rank": "yes", "serial number": 42} +++ perl { "name" => "ingy", "rank" => "yes", "serial number" => 42, } +++ libyaml_emit --- name: ingy rank: yes serial number: 42 PK��[-��q��magic.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 1; my $yaml = <<'...'; --- foo: foo bar: bar baz: baz ... my $exp = { foo => 'foo', bar => 'bar', baz => 'baz', }; { $yaml =~ /(.+)/s; is_deeply Load($1), $exp, 'Loading magical scalar works'; } PK��[�j�m��m��io-handle.tnu��[��use FindBin '$Bin'; use lib $Bin; use strict; my $t = $Bin; use utf8; use Encode; use IO::Pipe; use IO::File; use TestYAML tests => 6; use YAML::XS qw/DumpFile LoadFile/;; my $testdata = 'El país es medible. La patria es del tamaño del corazón de quien la quiere.'; # IO::Pipe my $pipe = new IO::Pipe; if ( fork() ) { # parent reads from IO::Pipe handle $pipe->reader(); my $recv_data = LoadFile($pipe); is length($recv_data), length($testdata), 'LoadFile from IO::Pipe read data'; is $recv_data, $testdata, 'LoadFile from IO::Pipe contents is correct'; } else { # child writes to IO::Pipe handle $pipe->writer(); DumpFile($pipe, $testdata); exit 0; } # IO::File my $file = "$t/dump-io-file-$$.yaml"; my $fh = new IO::File; # write to IO::File handle $fh->open($file, ">") or die $!; DumpFile($fh, $testdata); $fh->close; ok -e $file, 'IO::File output file exists'; # read from IO::File handle $fh->open($file, '<') or die $!; my $yaml = do { local $/; <$fh> }; is decode_utf8($yaml), "--- $testdata\n", 'LoadFile from IO::File contents is correct'; $fh->seek(0, 0); my $read_data = LoadFile($fh) or die $!; $fh->close; is length($read_data), length($testdata), 'LoadFile from IO::File read data'; is $read_data, $testdata, 'LoadFile from IO::File read data'; END { unlink $file if defined $file; # $file will be undefined in fork child. } PK��[`_Wo �� dump-heuristics.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 2; use utf8; is Dump("1234567890\n1234567890\n1234567890\n"), "--- \| 1234567890 1234567890 1234567890 ", 'Literal Scalar'; is Dump("A\nB\nC\n"), q{--- "A\nB\nC\n"} . "\n", 'Double Quoted Scalar'; PK��[��string_nulls.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 2; my $yaml = Dump "foo\0bar"; is $yaml, <<'...', 'Strings with nulls can Dump'; --- "foo\0bar" ... my $str = Load $yaml; is $str, "foo\0bar", 'Strings with nulls can Load'; PK��[�o��boolean-invalid.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests; my @disable = (['int 0', 0], ['string 0', '0'], ['empty string', ''], ['undef', undef]); my @invalid = (['int 1', 1], ['string 1', '1'], ['string foo', 'foo']); my $tests = (@disable + 2 @invalid); plan tests => $tests; for (@invalid) { my ($label, $test) = @$_; local $YAML::XS::Boolean = $test; my $data = eval { Load "dummy" }; # $@ and diag "ERROR: $@"; cmp_ok($@, '=~', qr{accepts}, "YAML::XS::Load: $label is an invalid setting"); my $yaml = eval { Dump { foo => 42 } }; # $@ and diag "ERROR: $@"; cmp_ok($@, '=~', qr{accepts}, "YAML::XS::Dump: $label is an invalid setting"); } for (@disable) { my ($label, $test) = @$_; local $YAML::XS::Boolean = $test; my $data = eval { Load "true" }; if ($@) { diag "ERROR: $@"; ok(0, "$label disables YAML::XS::Boolean"); } else { my $ref = ref $data; cmp_ok($ref, 'eq', '', "$label disables YAML::XS::Boolean"); } } PK��[��N��N��indent.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 2; $YAML::XS::Indent = 4; is Dump([{a => 1, b => 2, c => 3}]), <<'...', --- - a: 1 b: 2 c: 3 ... 'Dumped with indent 4'; $YAML::XS::Indent = 8; is Dump([{a => 1, b => 2, c => 3}]), <<'...', --- - a: 1 b: 2 c: 3 ... 'Dumped with indent 8'; PK��[�� empty.yamlnu��[��PK��[v��7��quote.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 4; is Dump('', [''], {foo => ''}), <<'...', 'Dumped empty string is quoted'; --- '' --- - '' --- foo: '' ... is Dump({}, [{}], {foo => {}}), <<'...', 'Dumped empty map is {}'; --- {} --- - {} --- foo: {} ... is Dump([], [[]], {foo => []}), <<'...', 'Dumped empty seq is []'; --- [] --- - [] --- foo: [] ... is Dump(['&1', '1', '\|2', '? foo', 'x: y', "\a\t\n\r"]), <<'...', --- - '&1' - '1' - '\|2' - '? foo' - 'x: y' - "\a\t\n\r" ... 'Dumped special scalars get quoted'; PK��[��?��?��null.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 5; my $array = [ undef, 'undef', 33, '~', undef, undef, '~/file.txt', ]; undef $array->[2]; my $yaml = Dump($array); is $yaml, <<'...', "Nulls dump as ~"; --- - ~ - undef - ~ - '~' - ~ - ~ - ~/file.txt ... my $array2 = Load($yaml); is_deeply $array2, $array, "YAML with undefs loads properly"; $yaml = "{foo, bar}\n"; my $perl = {foo => undef, bar => undef}; is_deeply Load($yaml), $perl, "Set notation has null values"; $yaml = <<'...'; --- foo: bar: - - - gorch: null ... $perl = {foo => undef, bar => [undef, [undef]], gorch => undef}; is_deeply Load($yaml), $perl, "Empty values Load as undefs"; $yaml = <<'...'; --- - - - - ... $perl = [[undef], [undef]]; is_deeply Load($yaml), $perl, "Can Load 'dash art'"; PK��[��loadfile-empty.tnu��[��use Test::More tests => 2; use YAML::XS; $_ = 'foo'; YAML::XS::LoadFile('t/empty.yaml'); pass 'LoadFile on empty file does not fail'; is $_, 'foo', '$_ is unchanged'; PK��[B�x� �� path-class.tnu��[��use FindBin '$Bin'; use lib $Bin; use strict; use warnings; use TestYAML tests => 2; use YAML::XS qw/ DumpFile LoadFile /; my $pc = eval "use Path::Class; 1"; my $file; SKIP: { skip "Path::Class need for this test", 2 unless $pc; my $data = { foo => "boo", }; $file = file("t", "path-class-$$.yaml"); DumpFile($file, $data); ok -f $file, "Path::Class $file exists"; my $data2 = LoadFile($file); is_deeply($data, $data2, "Path::Class roundtrip works"); } END { unlink $file if defined $file; } PK��[�kbZ��bug-stack.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAML tests => 1; use YAML::XS; sub libyaml { YAML::XS::Dump( $_[0] ); } my @x = (256, 'xxx', libyaml({foo => 'bar'})); isnt "@x", '256 xxx 256 xxx 256', "YAML::XS::LibYAML doesn't mess up the call stack"; PK��[/�� boolean-boolean.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests; local $YAML::XS::Boolean = "boolean"; my $yaml = <<'...'; --- boolfalse: false booltrue: true stringfalse: 'false' stringtrue: 'true' ... my $hash = eval { Load $yaml }; if ($@ and $@ =~ m{boolean}) { plan skip_all => "boolean not installed"; exit; } plan tests => 7; local $YAML::XS::Boolean = "boolean"; isa_ok($hash->{booltrue}, 'boolean'); isa_ok($hash->{boolfalse}, 'boolean'); cmp_ok($hash->{booltrue}, '==', 1, "boolean true is true"); cmp_ok($hash->{boolfalse}, '==', 0, "boolean false is false"); ok(! ref $hash->{stringtrue}, "string 'true' stays string"); ok(! ref $hash->{stringfalse}, "string 'false' stays string"); my $yaml2 = Dump($hash); cmp_ok($yaml2, 'eq', $yaml, "Roundtrip booleans ok"); PK��[��{��{��binary.tnu��[��use warnings; use strict; use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 1; my @data = ( "~\0\200", "null\0\200", "true\0\200", "false\0\200", ); my $yaml = <<'...'; --- - "~\0\x80" - "null\0\x80" - "true\0\x80" - "false\0\x80" ... is Dump(\@data), $yaml, 'Dumping zero bytes works'; # see https://github.com/ingydotnet/yaml-libyaml-pm/issues/91 PK��[U��libyaml-version.tnu��[��use Test::More; use YAML::XS (); my $libyaml_version = YAML::XS::LibYAML::libyaml_version(); diag "libyaml version = $libyaml_version"; cmp_ok($libyaml_version, '=~', qr{^\d+\.\d+(?:\.\d+)$}, "libyaml_version ($libyaml_version)"); done_testing; PK��[�r�e��e��ascii.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 7; is utf8::is_utf8(Load("--- Foo\n")), !!0, 'ASCII string does not have UTF8 flag on'; my $yaml1 = <<'...'; --- foo: foo bar: bar baz: baz ... { my $hash = Load($yaml1); is utf8::is_utf8($hash->{foo}), !!0, 'ASCII string string does not have UTF8 flag on'; is utf8::is_utf8($hash->{bar}), !!0, 'ASCII string string does not have UTF8 flag on'; is utf8::is_utf8($hash->{baz}), !!0, 'ASCII string string does not have UTF8 flag on'; } my $yaml2 = <<'...'; --- - foo - bar - baz ... { my $array = Load($yaml2); is utf8::is_utf8($array->[0]), !!0, 'ASCII string string does not have UTF8 flag on'; is utf8::is_utf8($array->[1]), !!0, 'ASCII string string does not have UTF8 flag on'; is utf8::is_utf8($array->[2]), !!0, 'ASCII string string does not have UTF8 flag on'; } PK��[ (��leak.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => ( 3 * ( 5 * 5 + 3 ) ); $YAML::XS::LoadBlessed = 1; use Scalar::Util qw(weaken); for ( 1 .. 3 ) { foreach my $case ( sub { "foo" }, sub { bless { foo => "bar" }, "Class" }, sub { [ 1 .. 3 ] }, sub { my $x = "foo"; \$x; }, sub { my $y = 42; my $x = \$y; \$x }, sub { my $h = {}; [ $h, $h ] }, #sub { my $glob = gensym(); $glob = { foo => "bar" }; \$glob }, #sub { sub { "foo " . $_[0] } }, #sub { sub () { 3 } }, ) { my $obj = $case->(); my $yaml = Dump($obj); ok( $yaml, "dumped" ); my $loaded = Load($yaml); is( ref($loaded), ref($obj), "loaded $loaded from $obj" ); is_deeply( $loaded, $obj, "eq deeply" ); if ( ref $obj ) { weaken($obj); weaken($loaded); is( $obj, undef, "dumped object not leaked" ); is( $loaded, undef, "loaded object not leaked" ); } } } PK��[�L��,��,��author-pod-syntax.tnu��[��#!perl BEGIN { unless ($ENV{AUTHOR_TESTING}) { print qq{1..0 # SKIP these tests are for testing by the author\n}; exit } } # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use strict; use warnings; use Test::More; use Test::Pod 1.41; all_pod_files_ok(); PK��[̟T��load.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 5; spec_file('t/data/basic.yml'); filters { yaml => ['parse_to_byte'], perl => ['eval'], }; run_is_deeply yaml => 'perl'; sub parse_to_byte { Load($_); } PK��[0�>��dump.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 4; spec_file('t/data/basic.yml'); filters { perl => ['eval', 'test_dump'], }; run_is perl => 'libyaml_emit'; sub test_dump { Dump(@_) \|\| "Dump failed"; } PK��[W_;l��TestYAML.pmnu��[��package TestYAML; use lib 'inc'; use Test::Base -Base; use blib; use File::Path 'rmtree'; our @EXPORT = qw(rmtree); no_diff; delimiters ('===', '+++'); PK��[Oy�� private.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 6; $YAML::XS::LoadBlessed = 1; my $a = Load(<<'...'); --- - !foo [1] - !Bar::Bar {fa: la} - !only lonely ... is ref($a), 'ARRAY', 'Load worked'; is ref($a->[0]), 'foo', 'Private tag works for array'; is ref($a->[1]), 'Bar::Bar', 'Private tag works for hash'; is ref($a->[2]), 'only', 'Private tag works for scalar'; is ${$a->[2]}, 'lonely', 'Scalar is correct'; like $a->[2], qr/^only=SCALAR/, 'Ref is SCALAR'; PK��[�^�[����tags.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 4; y2n("Explicit tag on array"); y2n("Very explicit tag on array"); y2n("Explicit tag on hash"); y2n("Very explicit tag on hash"); __DATA__ === Explicit tag on array +++ yaml --- !!perl/array - 2 - 4 +++ perl [2, 4]; === Very explicit tag on array +++ yaml --- !<tag:yaml.org,2002:perl/array> - 2 - 4 +++ perl [2, 4]; === Explicit tag on hash +++ yaml --- !!perl/hash 2: 4 +++ perl {2, 4}; === Very explicit tag on hash +++ yaml --- !<tag:yaml.org,2002:perl/hash> 2: 4 +++ perl {2, 4}; PK��[�ܙ�� bug-pvf.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAML tests => 1; use YAML::XS; my $string = "foo %s bar"; my $string2 = Load Dump $string; is $string2, $string, "Don't be using newSVpvf for strings, cuz it does a sprintf action"; PK��[�N^�� TestYAMLTests.pmnu��[��package TestYAMLTests; use lib 'inc'; use Test::Base -Base; @TestYAMLTests::EXPORT = qw(Load Dump n2y y2n nyny get_block_by_name); sub load_config() { my $config_file = shift; my $config = {}; return $config unless -f $config_file; open CONFIG, $config_file or die $!; my $yaml = do {local $/; <CONFIG>}; if ($yaml =~ /^yaml_module:\s+([\w\:]+)/m) { $config->{yaml_module} = $1; } if ($yaml =~ /^use_blib:\s+([01])/m) { $config->{use_blib} = $1; } $config->{use_blib} \|\|= 0; return $config; } my $yaml_module; BEGIN { my $config = load_config('t/yaml_tests.yaml'); if ($config->{use_blib}) { eval "use blib; 1" or die $@; } $yaml_module = $ENV{PERL_YAML_TESTS_MODULE} \|\| $config->{yaml_module} or die "Can't determine which YAML module to use for this test."; eval "require $yaml_module; 1" or die $@; $Y::T = $yaml_module; } sub get_block_by_name() { (my ($self), @_) = find_my_self(@_); $self->{blocks_by_name} \|\|= do { my $hash = {}; for my $block ($self->blocks) { $hash->{$block->name} = $block; } $hash; }; my $name = shift; my $object = $self->{blocks_by_name}{$name} or die "Can't find test named '$name'\n"; return $object; } sub nyny() { (my ($self), @_) = find_my_self(@_); my $test = $self->get_block_by_name(@_); my $perl = eval $test->perl; my $result = Dump(Load(Dump($perl))); for my $section (qw'yaml3 yaml yaml2') { my $yaml = $test->$section or next; if ($result eq $yaml) { is $result, $yaml, "NYNY: " . $test->name; return; } } my $yaml = $test->yaml; is $result, $yaml, "NYNY: " . $test->name; } sub n2y() { (my ($self), @_) = find_my_self(@_); my $test = $self->get_block_by_name(@_); my $perl = eval $test->perl; my $result = Dump($perl); for my $section (qw'yaml3 yaml yaml2') { my $yaml = $test->$section or next; if ($result eq $yaml) { is $result, $yaml, "Dump: " . $test->name; return; } } my $yaml = $test->yaml; is $result, $yaml, "Dump: " . $test->name; } sub y2n() { (my ($self), @_) = find_my_self(@_); my $test = $self->get_block_by_name(@_); my $perl = eval $test->perl; my $yaml = $test->yaml; is_deeply Load($yaml), $perl, "Load: " . $test->name; } sub Load() { no strict 'refs'; &{$yaml_module . "::Load"}(@_); } sub Dump() { no strict 'refs'; &{$yaml_module . "::Dump"}(@_); } no_diff; delimiters ('===', '+++'); package TestYAMLTests::Filter; use Test::Base::Filter -Base; sub load_yaml { TestYAMLTests::Load(@_); } sub dump_yaml { TestYAMLTests::Load(@_); } PK��[Z�)&��alias.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 15; my ($a, $b) = Load(<<'...'); --- - &one [ a, b, c] - foo: one --- &1 foo: &2 [2, 1] ... is "$a->[0]", "$a->[1]{'foo'}", 'Loading an alias works'; is "$b->{'foo'}", "$b->{'foo'}[0]", 'Another alias load test'; is "$b", "$b->{'foo'}[1]", 'Another alias load test'; my $value = { xxx => 'yyy' }; my $array = [$value, 'hello', $value]; is Dump($array), <<'...', 'Duplicate node has anchor/alias'; --- - &1 xxx: yyy - hello - 1 ... my $list = []; push @$list, $list; push @$list, $array; is Dump($list), <<'...', 'Dump of multiple and circular aliases'; --- &1 - 1 - - &2 xxx: yyy - hello - 2 ... my $hash = {}; $hash->{a1} = $hash->{a2} = []; $hash->{b1} = $hash->{b2} = []; $hash->{c1} = $hash->{c2} = []; $hash->{d1} = $hash->{d2} = []; # XXX Failed on 5.21.4. 'e1' got quoted because it looks like a number? # $hash->{e1} = $hash->{e2} = []; $hash->{f1} = $hash->{f2} = []; is Dump($hash), <<'...', 'Alias Order is Correct'; --- a1: &1 [] a2: 1 b1: &2 [] b2: 2 c1: &3 [] c2: 3 d1: &4 [] d2: 4 f1: &5 [] f2: 5 ... my $yaml = <<'...'; --- foo: &text \| sub foo { print "hello\n"; } bar: text ... $hash = Load($yaml); is $hash->{bar}, $hash->{foo}, 'Scalar anchor/aliases Load'; like $hash->{bar}, qr/"hello/, 'Aliased scalar has correct value'; $yaml = <<'...'; --- foo: &rx !!perl/regexp (?-xsim:lala) bar: rx ... $hash = Load($yaml); is $hash->{bar}, $hash->{foo}, 'Regexp anchor/aliases Load'; like "falala", $hash->{bar}, 'Aliased regexp works'; $yaml = <<'...'; --- - &empty - empty - &nulltag !!null - nulltag - &null null - null - &tilde ~ - tilde ... $array = Load($yaml); is scalar @$array, 8, 'Load "null" aliases works'; is scalar(grep defined, @$array), 0, 'Load "null" aliases returns undef'; $yaml = <<'...'; --- - &true true - true - &false false - false ... $array = Load($yaml); is scalar @$array, 4, 'Load boolean aliases works'; is $array->[1], 1, 'Load boolean true alias'; is $array->[3], '', 'Load boolean false alias'; PK��[��?W��code.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; sub cmp { my $str = shift; if ($str eq "fergal") { return 1; } elsif ($str eq "feargal") { return (0, "your name's not down, you're not coming in"); } else { return 0; } } { check_test( sub { cmp_deeply("fergal", code(\&cmp)); }, { actual_ok => 1, diag => '', }, "code ok" ); my ($prem, $res); ($prem, $res) = check_test( sub { cmp_deeply("feargal", code(\&cmp)); }, { actual_ok => 0, }, "code not ok" ); like($res->{diag}, "/your name's not down/", "diagnostics"); like($res->{diag}, "/feargal/", "diagnostics"); ($prem, $res) = check_test( sub { cmp_deeply("fazzer", code(\&cmp)); }, { actual_ok => 0, }, "code not ok" ); like($res->{diag}, "/it failed but it didn't say why/", "no diagnostics"); like($res->{diag}, "/fazzer/", "no diagnostics"); } PK��[�p&�L��L�� numbers.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 6; my ($a, $b, $c, $d) = (42, "42", 42, "42"); my $e = ">$c<"; my $f = $d + 3; { is Dump($a, $b, $c, $d), <<'...', "Dumping Integers and Strings"; --- 42 --- '42' --- 42 --- 42 ... my ($num, $float, $str) = Load(<<'...'); --- 42 --- 0.333 --- '02134' ... is Dump($num, $float, $str), <<'...', "Round tripping integers and strings"; --- 42 --- 0.333 --- '02134' ... } { local $YAML::XS::QuoteNumericStrings = 1; is Dump($a, $b, $c, $d), <<'...', "Dumping Integers and Strings"; --- 42 --- '42' --- 42 --- 42 ... my ($num, $float, $str) = Load(<<'...'); --- 42 --- 0.333 --- '02134' ... is Dump($num, $float, $str), <<'...', "Round tripping integers and strings"; --- 42 --- 0.333 --- '02134' ... } { local $YAML::XS::QuoteNumericStrings = 0; is Dump($a, $b, $c, $d), <<'...', "Dumping Integers and Strings"; --- 42 --- 42 --- 42 --- 42 ... my ($num, $float, $str) = Load(<<'...'); --- 42 --- 0.333 --- '02134' ... is Dump($num, $float, $str), <<'...', "Round tripping integers and strings"; --- 42 --- 0.333 --- 02134 ... } PK��[%J�� dump-int.tnu��[��use strict; use warnings; use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 5; #use Devel::Peek (); use B (); my $data = { int => 42 }; my $flags = B::svref_2object(\$data->{int})->FLAGS; my $string = $flags & B::SVp_POK; my $int = $flags & B::SVp_IOK; #diag("Flags=$flags int=$int string=$string"); cmp_ok($string, '==', 0, "Before Dump we don't have a string"); cmp_ok($int, '>=', 0, "Before Dump we have an int"); #Devel::Peek::Dump($data->{int}); # Dump shouldn't modify the original data my $dump = Dump $data; my $flags2 = B::svref_2object(\$data->{int})->FLAGS; $string = $flags2 & B::SVp_POK; $int = $flags2 & B::SVp_IOK; #diag("Flags=$flags 2int=$int string=$string"); cmp_ok($string, '==', 0, "After Dump we still don't have a string"); cmp_ok($int, '>=', 0, "After Dump we still have an int"); cmp_ok($flags2, '==', $flags, "Flags are the same as before ($flags == $flags2)"); #Devel::Peek::Dump($data->{int}); PK��[xa�˥��long_plain_wrap.tnu��[��use Test::More; # tests => 1; use YAML::XS; plan skip_all => 'Failing test. Not yet implemented'; my $p = {my_key => "When foo or foobar is used, everyone understands that these are just examples, and they dont really exist."}; my $e = <<'...'; --- my_key: When foo or foobar is used, everyone understands that these are just examples, and they dont really exist. ... is Dump($p), $e, "Long plain scalars don't wrap"; PK��[�3�7��7��yaml_tests.yamlnu��[��yaml_module: YAML::XS use_blib: 1 exclude: - scalars.t PK��[�R>��api.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAML tests => 20; package A; use YAML::XS; package B; use YAML::XS(); package C; use YAML::XS('DumpFile', 'LoadFile'); package D; use YAML::XS ':all'; package E; use YAML::XS('Dump', 'LoadFile'); package main; ok defined(&A::Dump), 'Dump is exported by default'; ok defined(&A::Load), 'Load is exported by default'; ok not(defined(&A::DumpFile)), 'DumpFile is not exported by default'; ok not(defined(&A::LoadFile)), 'LoadFile is not exported by default'; ok not(defined(&B::Dump)), 'Dump is not exported for ()'; ok not(defined(&B::Load)), 'Load is not exported for ()'; ok not(defined(&B::DumpFile)), 'DumpFile is not exported for ()'; ok not(defined(&B::LoadFile)), 'LoadFile is not exported for ()'; ok not(defined(&C::Dump)), 'Dump is not exported for qw(LoadFile DumpFile)'; ok not(defined(&C::Load)), 'Load is not exported for qw(LoadFile DumpFile)'; ok defined(&C::DumpFile), 'DumpFile is exportable'; ok defined(&C::LoadFile), 'LoadFile is exportable'; ok defined(&D::Dump), 'Dump is exported for :all'; ok defined(&D::Load), 'Load is exported for :all'; ok defined(&D::DumpFile), 'DumpFile is exported for :all'; ok defined(&D::LoadFile), 'LoadFile is exported for :all'; ok defined(&E::Dump), 'Dump is exported for qw(LoadFile Dump)'; ok not(defined(&E::Load)), 'Load is not exported for qw(LoadFile Dump)'; ok not(defined(&E::DumpFile)), 'DumpFile is exported for qw(LoadFile Dump)'; ok defined(&E::LoadFile), 'LoadFile is not exported for qw(LoadFile Dump)'; PK��[k�U ��ref-scalar.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 11; run { my $block = shift; my @values = eval $block->perl; is Dump(@values), $block->yaml, "Dump - " . $block->name unless $block->SKIP_DUMP; is_deeply [Load($block->yaml)], \@values, "Load - " . $block->name; }; my @warn; $SIG{__WARN__} = sub { push(@warn, shift) }; my $z = YAML::XS::Load(<<EOY); --- foo: - url: &1 scheme: http EOY pop @{$z->{foo}}; is_deeply \@warn, [], "No free of unref warnings"; __DATA__ === Simple scalar ref +++ perl \ 42; +++ yaml --- !!perl/ref =: 42 === Ref to scalar ref +++ perl \\ "foo bar"; +++ yaml --- !!perl/ref =: !!perl/ref =: foo bar === Scalar refs an aliases +++ perl my $x = \\ 3.1415; [$x, $$x]; +++ yaml --- - !!perl/ref =: &1 !!perl/ref =: 3.1415 - 1 === Ref to undef +++ perl my $x = {foo => \undef}; +++ yaml --- foo: !!perl/ref =: ~ === Circular ref to scalar +++ perl my $x; $x = \$x; +++ yaml --- &1 !!perl/ref =: 1 PK��[�(�K��K��load_standard_tags.tnu��[��use strict; use warnings; use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 27; use B (); my $yaml = <<"EOM"; - !!str - !!str ~ - !!str null - !!str 23 - !!str true - !!str false - !!null ~ - !!null null - !!null - !!int 23 - !!float 23.3 EOM my @expected = ('', '~', 'null', "23", 'true', 'false'); my $data = Load $yaml; ok(defined $data->[0], "Empty node with !!str is defined"); ok(defined $data->[1], "Node '!!str ~' is defined"); ok(defined $data->[2], "Node '!!str null' is defined"); ok((not defined $data->[6]), "Node '!!null ~' is not defined"); ok((not defined $data->[7]), "Node '!!null null' is not defined"); ok((not defined $data->[8]), "Node '!!null' is not defined"); for my $i (0 .. $#expected) { cmp_ok($data->[$i], 'eq', $expected[$i], "data[$i] equals '$expected[$i]'"); } my @flags = map { B::svref_2object(\$_)->FLAGS } @$data; for my $i (0 .. 5) { my $flags = $flags[$i]; ok($flags & B::SVp_POK, "data[$i] has string flag"); ok(not($flags & B::SVp_IOK), "data[$i] does not have int flag"); } ok($flags[9] & B::SVp_IOK, "data[9] has int flag"); ok($flags[10] & B::SVp_NOK, "data[10] has num flag"); my $yaml2 = <<"EOM"; - !!map a: b - !!seq - a - b EOM my $data2 = Load $yaml2; my $exp = [ { a => 'b' }, [ 'a', 'b' ], ]; is_deeply($data2, $exp, "Standard tags !!map and !!seq work"); PK��[=� �C��C��error.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { my ($prem, @res) = eval { run_tests( sub { cmp_deeply([shallow([])], [[]], "bad special"); } ); }; like($@, qr/^Found a special comparison in \$data->\[0\]\nYou can only use specials in the expects structure/, "bad special"); } PK��[��p��load-blessed.tnu��[��use FindBin '$Bin'; use lib $Bin; use TestYAMLTests tests => 15; $YAML::XS::LoadBlessed = 1; my $yaml = <<"EOM"; local_array: !Foo::Bar [a] local_hash: !Foo::Bar { a: 1 } local_scalar: !Foo::Bar a hash: !!perl/hash:Foo::Bar { a: 1 } array: !!perl/array:Foo::Bar [a] regex: !!perl/regexp:Foo::Bar OK scalar: !!perl/scalar:Foo::Bar scalar EOM my $objects = Load $yaml; isa_ok($objects->{local_array}, "Foo::Bar", "local tag (array)"); isa_ok($objects->{local_hash}, "Foo::Bar", "local tag (hash)"); isa_ok($objects->{local_scalar}, "Foo::Bar", "local tag (scalar)"); isa_ok($objects->{array}, "Foo::Bar", "perl tag (array)"); isa_ok($objects->{hash}, "Foo::Bar", "perl tag (hash)"); isa_ok($objects->{regex}, "Foo::Bar", "perl tag (regexp)"); isa_ok($objects->{scalar}, "Foo::Bar", "perl tag (scalar)"); local $YAML::XS::LoadBlessed = 0; my $hash = Load $yaml; cmp_ok(ref $hash->{local_array}, 'eq', 'ARRAY', "Array not blessed (local)"); cmp_ok(ref $hash->{local_hash}, 'eq', 'HASH', "Hash not blessed (local)"); cmp_ok(ref $hash->{local_scalar}, 'eq', '', "Scalar not blessed (local)"); cmp_ok(ref $hash->{array}, 'eq', 'ARRAY', "Array not blessed"); cmp_ok(ref $hash->{hash}, 'eq', 'HASH', "Hash not blessed"); cmp_ok(ref $hash->{regex}, 'eq', 'Regexp', "Regexp not blessed"); cmp_ok(ref $hash->{scalar}, 'eq', '', "Scalar not blessed"); my $expected = { local_array => ["a"], local_hash => { a => 1 }, local_scalar => "a", hash => { a => 1 }, array => ["a"], regex => qr{OK}, scalar => "scalar", }; if ($hash->{regex} =~ m/:OK/) { $hash->{regex} = $expected->{regex}; } is_deeply($hash, $expected); # !!perl/glob and !!perl/ref aren't blessed at the moment. # !!perl/code isn't loaded at the moment PK��[� I��tied.tnu��[��use warnings; use strict; use FindBin '$Bin'; use lib $Bin; use Test::More; use YAML::XS qw/ Dump /; BEGIN { if ($] < 5.010000) { plan skip_all => 'needs perl 5.10 or higher'; } else { plan tests => 4; } } use Tie::Array; use Tie::Hash; subtest 'tie-array' => sub { my $yaml = <<'...'; --- - foo - bar - baz ... tie my @av, 'Tie::StdArray'; $av[0] = 'foo'; $av[1] = 'bar'; $av[2] = 'baz'; is Dump(\@av), $yaml, 'Dumping tied array works'; }; subtest 'tie-hash' => sub { my $yaml = <<'...'; --- bar: bar baz: baz foo: foo ... tie my %hv, 'Tie::StdHash'; $hv{foo} = 'foo'; $hv{bar} = 'bar'; $hv{baz} = 'baz'; is Dump(\%hv), $yaml, 'Dumping tied hash works'; }; { package Tie::OneIterationOnly; my @KEYS = qw(bar baz foo); sub TIEHASH { return bless \do { my $x }, shift; } sub FIRSTKEY { my ($self) = @_; return shift @KEYS; } sub NEXTKEY { my ($self, $last) = @_; return shift @KEYS; } sub FETCH { my ($self, $key) = @_; return; } } subtest 'tie-special' => sub { my $yaml3 = <<'...'; --- {} ... tie my %hv, 'Tie::OneIterationOnly'; is Dump(\%hv), $yaml3, 'Dumping tied hash works'; }; subtest 'nested-tie' => sub { my $ref = [qw/ a b c /]; my %foo = (foo => $ref, bar => $ref ); tie my %bar, 'TestStdHash', %foo; my $yaml = Dump \%bar; my $exp = <<'EOM'; --- bar: &1 - a - b - c foo: 1 EOM is $yaml, $exp, 'Dumping nested tied hash works'; my @foo = ($ref, $ref); tie my @bar, 'TestStdArray', @foo; $yaml = Dump \@bar; $exp = <<'EOM'; --- - &1 - a - b - c - 1 EOM is $yaml, $exp, 'Dumping nested tied array works'; }; package TestStdHash; our @ISA = qw/ Tie::StdHash /; sub TIEHASH { my $class = shift; return bless {@_}, $class } sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} } sub NEXTKEY { each %{$_[0]} } sub FETCH { $_[0]->{$_[1]} } package TestStdArray; our @ISA = qw/ Tie::StdArray /; sub TIEARRAY { my $class = shift; return bless [@_], $class } sub FETCH { $_[0]->[ $_[1]] } sub FETCHSIZE { scalar @{ $_[0] } } PK��[zI�"��03.github-issue-5.tnu��[��#!/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; PK��[J��£:��:��01.legacy.tnu��[��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; } PK��[&�L~+��+��02.legacy-symtogsafe.tnu��[��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; } PK��[k%�E��E�� 00.load.tnu��[��use Test::More tests => 1; BEGIN { use_ok('File::Copy::Recursive') } PK��[��04.readonly-dir.tnu��[��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; PK��[d~r�^ ��^ ��05.legacy-pathmk_unc.tnu��[��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; } PK��[��Data-Validate-IP.tnu��[��use strict; use warnings; use lib 't/lib'; use Test::Data::Validate::IP; use Test::More 0.88; run_tests(); done_testing(); PK��[��o��Data-Validate-IP-slow.tnu��[��use strict; use warnings; use lib 't/lib'; BEGIN { ## no critic (Variables::RequireLocalizedPunctuationVars) $ENV{DVI_NO_SOCKET} = 1; } use Test::Data::Validate::IP; use Test::More 0.88; run_tests(); done_testing(); PK��[��V%(��%(��lib/Test/Data/Validate/IP.pmnu��[��package # hide from PAUSE Test::Data::Validate::IP; use strict; use warnings; use Data::Validate::IP; use Exporter qw( import ); use Test::More 0.88; ## no critic (Modules::ProhibitAutomaticExportation) our @EXPORT = 'run_tests'; ## use critic my $object = Data::Validate::IP->new(); my %ipv4_types = ( private => [qw(10.0.0.1 172.16.0.1 192.168.0.1)], public => [qw(1.2.3.4 123.123.44.55 216.17.184.1)], loopback => [qw(127.0.0.1)], testnet => [qw(192.0.2.9 198.51.100.33 203.0.113.44)], multicast => [qw(224.0.0.1)], anycast => [qw(192.88.99.45)], linklocal => [qw(169.254.0.1)], unroutable => [ qw( 0.0.0.1 100.64.1.2 192.0.0.4 198.18.0.55 240.0.0.4 255.255.255.254 255.255.255.255 ) ], ); my %ipv6_types = ( private => [ qw( fc00:: fc01::1234 fdef:: fdff:ffff:ffff:ffff:ffff:ffff:ffff:ffff ) ], public => [ qw( ::abcd:1234 1:: 2:: 1:1:1:1:: 2001:abcd:: abcd:: ) ], loopback => [qw(::1)], ipv4_mapped => [ qw( ::ffff:0:0 ::ffff:0:1234 ::ffff:1.2.3.4 ::ffff:ffff:ffff ) ], discard => [ qw( 100:: 100::1234 100:0000:0000:0000:ffff:ffff:ffff:ffff ) ], multicast => [ qw( ff00:: ffff:: ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff ) ], linklocal => [ qw( fe80:: fe89:: febf:: febf:ffff:ffff:ffff:ffff:ffff:ffff:ffff ) ], special => [ [ '2001::' => [qw( teredo )] ], [ '2001::1234' => [qw( teredo )] ], qw( 2001:1ff:ffff:ffff:ffff:ffff:ffff:ffff ) ], teredo => [ qw( 2001:: 2001::1234 2001:0:ffff:ffff:ffff:ffff:ffff:ffff ) ], orchid => [ qw( 2001:10:: 2001:10::1234 2001:001F:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF ) ], documentation => [ qw( 2001:db8:: 2001:db8::1234 2001:0db8:ffff:ffff:ffff:ffff:ffff:ffff ) ], unspecified => [ qw( :: ::0 ) ], ); my %ip_types = map { $_ => [ @{ $ipv4_types{$_} }, @{ $ipv6_types{$_} } ] } qw( linklocal loopback multicast private public ); sub run_tests { _ipv4_basic_tests(); _type_tests( \%ipv4_types, 4 ); _ipv4_innet_tests(); _ipv6_basic_tests(); _type_tests( \%ipv6_types, 6 ); # Tests for subs without a family _ip_basic_tests(); _type_tests( \%ip_types ); } sub _ipv4_basic_tests { my @valid_ipv4 = qw( 0.0.0.0 1.2.3.4 216.17.184.1 255.255.255.255 ); for my $ip (@valid_ipv4) { is( is_ipv4($ip), $ip, "is_ipv4($ip) returns $ip" ); is( $object->is_ipv4($ip), $ip, "->is_ipv4($ip) returns $ip" ); } my @invalid_ipv4 = ( qw( 2067:fa88::0 www.neely.cx 216.17.184.G 216.17.184.1. 216.17.184 216.17.184. 256.17.184.1 216.017.184.1 016.17.184.1 ), "1.1.1.1\0 exploit goes here", ); for my $ip (@invalid_ipv4) { is( is_ipv4($ip), undef, "is_ipv4($ip) returns undef" ); is( $object->is_ipv4($ip), undef, "->is_ipv4($ip) returns undef" ); for my $type ( sort keys %ipv4_types ) { my ( $is_sub_name, $is_sub ) = _sub_for_type( $type, 4 ); is( $is_sub->($ip), undef, "$is_sub_name($ip) returns undef" ); is( $object->$is_sub_name($ip), undef, "->$is_sub_name($ip) returns undef" ); } } } sub _ipv4_innet_tests { my @tests = ( [ '216.17.184.1', '216.17.184.0/24', 1 ], [ '127.0.0.1', '216.17.184.0/24', 0 ], [ 'invalid', '216.17.184.0/24', 0 ], [ '0.0.0.0', 'default', 1 ], [ '1.2.3.4', 'default', 1 ], [ '216.240.32.1', '216.240.32.1', 1 ], ); # These are accepted for backwards compatibility with the time when we # used Net::Netmask. my @deprecated = ( [ '216.240.32.1', '216.240.32/24', 1, 1 ], [ '216.240.32.1', '216.240/16', 1, 1 ], [ '216.240.32.1', '216.240.32.0:255.255.255.0', 1, 1 ], [ '216.240.32.1', '216.240.32.0-255.255.255.0', 1, 1 ], [ '216.240.32.1', '216.240.32', 1, 1 ], [ '216.240.32.1', '216.240', 1, 1 ], [ '216.240.32.1', '216', 1, 1 ], [ '216.240.32.1', '216.240.32.0#0.0.31.255', 1, 1 ], ); my @warnings; for my $triplet ( @tests, @deprecated ) { my ( $ip, $network, $is_member, $is_deprecated ) = @{$triplet}; my $expect = $is_member ? $ip : undef; my $expect_string = $expect \|\| 'undef'; local $SIG{__WARN__} = sub { push @warnings, @_ } if $is_deprecated; is( is_innet_ipv4( $ip, $network ), $expect, "is_innet_ipv4($ip, $network) returns $expect_string" ); } is( scalar @warnings, 1, 'got one warning from is_innet_ipv4' ); like( $warnings[0], qr/\QUse of non-CIDR notation for networks with is_innet_ipv4() is deprecated/, 'got expected deprecation warning' ); like( $warnings[0], qr/at line \d+ of Test::Data::Validate::IP in sub Test::Data::Validate::IP::_ipv4_innet_tests/, 'deprecation warning identifies caller' ); } sub _ipv6_basic_tests { my @valid = qw( 2067:fa88::0 2067:FA88::1 2067:FA88:: 2001:4888:205:7126:e0:120:: 2607:fa88::8a2e:370:7334 2001:0db8:0000:0000:0000:0000:1428:57ab 2001:0db8:0000:0000:0000::1428:57ab 2001:0db8:0:0:0:0:1428:57ab 2001:0db8:0:0::1428:57ab 2001:0db8::1428:57ab 2001:db8::1428:57ab :: ::0 ::1 ::ffff:12.34.56.78 0:0:0:0:0:ffff:12.34.56.78 ); for my $ip (@valid) { is( is_ipv6($ip), $ip, "is_ipv6($ip) returns $ip" ); is( $object->is_ipv6($ip), $ip, "->is_ipv6($ip) returns $ip" ); } my @invalid = ( qw( 0000:00:0000:0000:0000:0000:0000:00000 2067:fa88 2067:FA88 2067::: 2067:::1 2067::1: 216.17.184.1 bbb.bbb.bbb ::: g123::1234 :abcd ), "::1\0 invalid", ); for my $ip (@invalid) { is( is_ipv6($ip), undef, "is_ipv6($ip) returns undef" ); is( $object->is_ipv6($ip), undef, "->is_ipv6($ip) returns undef" ); for my $type ( sort keys %ipv6_types ) { my ( $is_sub_name, $is_sub ) = _sub_for_type( $type, 6 ); is( $is_sub->($ip), undef, "$is_sub_name($ip) returns undef" ); is( $object->$is_sub_name($ip), undef, "->$is_sub_name($ip) returns undef" ); } } } sub _ip_basic_tests { my @valid = qw( 1.1.1.1 2067:fa88::0 ::1.1.1.1 ); for my $ip (@valid) { is( is_ip($ip), $ip, "is_ip($ip) returns $ip" ); is( $object->is_ip($ip), $ip, "->is_ip($ip) returns $ip" ); } my @invalid = ( qw( 2067:fa88 216.17.184 :216.17.184 ), "::1\0 invalid" ); for my $ip (@invalid) { is( is_ip($ip), undef, "is_ip($ip) returns undef" ); is( $object->is_ip($ip), undef, "->is_ip($ip) returns undef" ); } } sub _type_tests { my $types = shift; my $ip_number = shift; my @types = sort keys %{$types}; for my $type (@types) { for my $test ( @{ $types->{$type} } ) { my ( $ip, $is_also ) = ref $test ? @{$test} : ( $test, [] ); my ( $is_sub_name, $is_sub ) = _sub_for_type( $type, $ip_number ); is( $is_sub->($ip), $ip, "$is_sub_name($ip) returns $ip" ); is( $object->$is_sub_name($ip), $ip, "->$is_sub_name($ip) returns $ip" ); for my $other ( sort grep { $_ ne $type } @types ) { next if grep { $_ eq $other } @{$is_also}; my ( $other_sub_name, $other_sub ) = _sub_for_type( $other, $ip_number ); ## no critic (Subroutines::ProtectPrivateSubs) if ( Data::Validate::IP::_network_is_subnet_of( $type, $other ) ) { is( $other_sub->($ip), $ip, "$other_sub_name($ip) returns $ip" ); is( $object->$other_sub_name($ip), $ip, "->$other_sub_name($ip) returns $ip" ); } else { is( $other_sub->($ip), undef, "$other_sub_name($ip) returns undef" ); is( $object->$other_sub_name($ip), undef, "->$other_sub_name($ip) returns undef" ); } } } } } sub _sub_for_type { my $type = shift; my $ip_number = shift; my $sub_name = 'is_' . $type . '_ip'; $sub_name .= 'v' . $ip_number if defined $ip_number; my $sub = do { ## no critic (TestingAndDebugging::ProhibitNoStrict) no strict 'refs'; \&{$sub_name}; } or die "No sub named $sub_name was imported"; return ( $sub_name, $sub ); } 1; PK��[�M�� Untaint.tnu��[��#!perl -T use strict; use warnings; use Test::More 0.88; use Test::Requires { 'Test::Taint' => 0, }; use Data::Validate::IP; unless ( taint_checking_ok('taint is enabled') ) { done_testing(); exit 0; } _test_good_data( 'is_ipv4', '1.2.3.4' ); _test_bad_data( 'is_ipv4', '1.2.3.999' ); _test_good_data( 'is_innet_ipv4', [ '216.17.184.1', '216.17.184.0/24' ], '216.17.184.1' ); _test_bad_data( 'is_innet_ipv4', [ '127.0.0.1', '216.17.184.0/24' ], ); _test_good_data( 'is_private_ipv4', '10.0.0.1' ); _test_bad_data( 'is_private_ipv4', '1.2.3.4' ); _test_good_data( 'is_public_ipv4', '1.2.3.4' ); _test_bad_data( 'is_public_ipv4', '10.0.0.1' ); _test_good_data( 'is_loopback_ipv4', '127.0.0.1' ); _test_bad_data( 'is_loopback_ipv4', '10.0.0.1' ); _test_good_data( 'is_testnet_ipv4', '192.0.2.9' ); _test_bad_data( 'is_testnet_ipv4', '10.0.0.1' ); _test_good_data( 'is_multicast_ipv4', '224.0.0.1' ); _test_bad_data( 'is_multicast_ipv4', '10.0.0.1' ); _test_good_data( 'is_linklocal_ipv4', '169.254.0.1' ); _test_bad_data( 'is_linklocal_ipv4', '10.0.0.1' ); _test_good_data( 'is_ipv6', '::' ); _test_good_data( 'is_ipv6', 'fff0:1234::' ); _test_bad_data( 'is_ipv6', 'fffff::' ); _test_good_data( 'is_linklocal_ipv6', 'fe80:db8::4' ); _test_bad_data( 'is_linklocal_ipv6', 'fffff::' ); sub _test_good_data { my $meth = shift; my $good = shift; my $expect = shift \|\| $good; my @args = _args($good); tainted_ok_deeply( \@args, 'all arguments are tainted' ); my $return = Data::Validate::IP->new()->$meth(@args); is( $return, $expect, "$meth(@args) returns $expect with tainted value" ); untainted_ok( $return, "$meth() returns untained value when value is valid" ); } sub _test_bad_data { my $meth = shift; my $bad = shift; my @args = _args($bad); tainted_ok_deeply( \@args, 'all arguments are tainted' ); my $return = Data::Validate::IP->new()->$meth(@args); is( $return, undef, "$meth(@args) returns undef with tainted value" ); } sub _args { my $args = shift; my @args = ref $args ? @{$args} : $args; taint(@args); return @args; } done_testing(); PK��[�B!.'��'��none.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_test( sub { cmp_deeply("wine", none("beer", "wine")) }, { actual_ok => 0, diag => <<EOM, Comparing \$data with None got : 'wine' expected : None of ( 'beer', 'wine' ) EOM }, "none eq fail" ); check_test( sub { cmp_deeply("whisky", none("beer", "wine")) }, { actual_ok => 1, diag => "", }, "none eq ok" ); check_test( sub { cmp_deeply("whisky", none("beer") \| "wine") }, { actual_ok => 1, diag => "", }, "none with \| match none" ); check_test( sub { cmp_deeply("wine", none("beer") \| "wine") }, { actual_ok => 1, diag => "", }, "none with \| match alternative" ); check_test( sub { cmp_deeply("beer", none("beer") \| "wine") }, { actual_ok => 0, diag => <<EOM, Comparing \$data with Any got : 'beer' expected : Any of ( None of ( 'beer' ), 'wine' ) EOM }, "none with \| fail" ); } PK��[t ��set.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_test( sub { cmp_deeply([], set()); }, { actual_ok => 1, diag => "", }, "empty eq" ); check_test( sub { cmp_deeply(["a"], set("a", "a")); }, { actual_ok => 1, diag => "", }, "empty eq" ); check_test( sub { cmp_deeply(['a', 'b', 'b', ['c', 'd']], set('b', 'a', ['c', 'd'], 'b')); }, { actual_ok => 1, diag => "", }, "3 elem eq" ); check_test( sub { cmp_deeply(['a', [], 'b', 'b'], set()); }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a Set Extra: 'a', 'b', 1 reference EOM }, "empty extra" ); check_test( sub { cmp_deeply([], set('a', [], 'a', 'b')); }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a Set Missing: 'a', 'b', 1 reference EOM }, "empty missing" ); check_test( sub { cmp_deeply(['a', 'a', 'b', [\"c"], "d", []], set({}, 'a', [\"c"], 'd', 'd', "e")); }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a Set Missing: 'e', 1 reference Extra: 'b', 1 reference EOM }, "extra and missing" ); check_test( sub { cmp_deeply("a", set()); }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a Set got : 'a' expect : An array to use as a Set EOM }, "no array" ); check_test( sub { cmp_deeply(['a',['a', 'b', 'b'], ['c', 'd', 'c','d'], ['a', 'b', 'a']], set(set('c', 'd', 'd'), set('a', 'b', 'a'), set('c', 'c', 'd'), 'a') ); }, { actual_ok => 1, diag => '', }, "set of sets eq" ); check_test( sub { cmp_deeply([['a', 'b', 'c'], ['c', 'd', 'c'], ['a', 'b', 'a']], set(set('c', 'd', 'c'), set('a', 'b', 'a'), set('b', 'b', 'a')) ); }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a Set Extra: 1 reference EOM }, "set of sets not eq" ); my $b1 = set('a'); my $b2 = [set('b')]; $b1->add($b1, $b2, $b1); $b2->[0]->add($b2, $b1, $b2); my $v1 = ['a']; my $v2 = [['b']]; push(@$v1, $v2, $v1, $v2); push(@{$v2->[0]}, $v1, $v2, $v1); check_test( sub { cmp_deeply($v1, $b1); }, { actual_ok => 1, diag => '', }, "circular double set eq" ); $b1->add('b', 'b'); push(@$v1, 'c', 'c'); check_test( sub { cmp_deeply($v1, $b1); }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a Set Missing: 'b' Extra: 'c' EOM }, "circular double set not eq" ); check_test( sub { cmp_set([1, 2, 2], [1, 1, 2]); }, { actual_ok => 1, }, "cmp_set eq" ); check_test( sub { cmp_set([1, 2, 2, 3], [1, 1, 2]); }, { actual_ok => 0, }, "cmp_set not eq" ); } { my $a1 = \"a"; my $b1 = \"b"; my $a2 = \"a"; my $b2 = \"b"; TODO: { todo_skip( "Because I want to get it out the door see notes on bags and sets", 5 ); check_test( sub { cmp_deeply([[\'a', \'b']], set(set($a2, $b1), set($b2, $a1))) }, { actual_ok => 1, diag => "", }, "set compare()" ); } check_test( sub { cmp_deeply(['a', 'b', 'c', 'a'], supersetof('b', 'a', 'b')); }, { actual_ok => 1, diag => "", }, "supersetof yes" ); check_test( sub { cmp_deeply(['a', 'b', 'c', 'a'], supersetof('d', 'b', 'd')); }, { actual_ok => 0, diag => <<'EOM', Comparing $data as a SuperSet Missing: 'd' EOM }, "supersetof no" ); check_test( sub { cmp_deeply(['b', 'a', 'b'], subsetof('a', 'b', 'c', 'a')); }, { actual_ok => 1, diag => "", }, "subsetof yes" ); check_test( sub { cmp_deeply(['d', 'b', 'd'], subsetof('a', 'b', 'c', 'a')); }, { actual_ok => 0, diag => <<'EOM', Comparing $data as a SubSet Extra: 'd' EOM }, "subsetof no" ); } { check_test( sub { cmp_deeply(['a', 'b', 'c'], noneof('d', 'e', 'f')); }, { actual_ok => 1, diag => "", }, "noneof yes" ); check_test( sub { cmp_deeply(['a', 'b', 'c'], noneof('b', 'c', 'd', 'e')); }, { actual_ok => 0, diag => <<'EOM', Comparing $data as a NoneOf Extra: 'b', 'c' EOM }, "noneof no" ); } { check_test( sub { cmp_deeply([1, undef, undef], set(undef, 1, undef)); }, { actual_ok => 1, diag => "", }, "undef warnings" ); check_test( sub { cmp_deeply([1, undef], set(1)); }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a Set Extra: undef EOM }, "warnings extra" ); } PK��[%S��bag.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_test( sub { cmp_deeply([], bag()); }, { actual_ok => 1, diag => "", }, "empty eq" ); check_test( sub { cmp_deeply(['a', 'b', 'b', ['c', 'd']], bag('b', 'a', ['c', 'd'], 'b')); }, { actual_ok => 1, diag => "", }, "elem eq" ); check_test( sub { cmp_deeply(['a', [], 'b', 'b'], bag()); }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a Bag Extra: 'a', 'b', 'b', 1 reference EOM }, "empty extra" ); check_test( sub { cmp_deeply([], bag('a', [], 'a', 'b')); }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a Bag Missing: 'a', 'a', 'b', 1 reference EOM }, "empty missing" ); check_test( sub { cmp_deeply(['a', 'a', 'b', [\"c"], "d", []], bag({}, 'a', [\"c"], 'd', 'd', "e")); }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a Bag Missing: 'd', 'e', 1 reference Extra: 'a', 'b', 1 reference EOM }, "extra and missing" ); check_test( sub { cmp_deeply("a", bag()); }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a Bag got : 'a' expect : An array to use as a Bag EOM }, "no array" ); check_test( sub { cmp_deeply(['a', ['a', 'b', 'b'], ['c', 'd', 'c'], ['a', 'b', 'a']], bag(bag('c', 'c', 'd'), bag('a', 'b', 'a'), bag('a', 'b', 'b'), 'a') ); }, { actual_ok => 1, diag => '', }, "bag of bags eq" ); check_test( sub { cmp_deeply(['a', ['a', 'b', 'b'], ['c', 'd', 'c'], ['a', 'b', 'a']], bag(bag('c', 'd', 'd'), bag('a', 'b', 'a'), bag('a', 'b', 'b'), 'a') ); }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a Bag Missing: 1 reference Extra: 1 reference EOM }, "bag of bags not eq" ); my $b1 = bag('a'); my $b2 = [bag('b')]; $b1->add($b2, $b1); $b2->[0]->add($b1, $b2); my $v1 = ['a']; my $v2 = [['b']]; push(@$v1, $v2, $v1); push(@{$v2->[0]}, $v1, $v2); check_test( sub { cmp_deeply($v1, $b1); }, { actual_ok => 1, diag => '', }, "circular double bag eq" ); $b1->add('b', 'b'); push(@$v1, 'c', 'c'); check_test( sub { cmp_deeply($v1, $b1); }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a Bag Missing: 'b', 'b' Extra: 'c', 'c' EOM }, "circular double set not eq" ); check_test( sub { cmp_bag([1, 2, 2], [2, 1, 2]); }, { actual_ok => 1, }, "cmp_bag eq" ); check_test( sub { cmp_bag([1, 2, 2], [1, 2, 1, 2]); }, { actual_ok => 0, }, "cmp_bag not eq" ); check_test( sub { cmp_bag([1], [1], 'name1'); }, { actual_ok => 1, name => 'name1', }, "cmp_bag returns name" ); check_test( sub { cmp_bag([1], [2], 'name2'); }, { actual_ok => 0, name => 'name2', }, "cmp_bag returns name" ); check_test( sub { cmp_deeply(['a', 'b', 'c', 'a', 'a', 'b'], superbagof('b', 'a', 'b')); }, { actual_ok => 1, diag => "", }, "superbagof yes" ); check_test( sub { cmp_deeply(['a', 'b', 'c', 'a'], superbagof('d', 'b', 'd', 'b')); }, { actual_ok => 0, diag => <<'EOM', Comparing $data as a SuperBag Missing: 'b', 'd', 'd' EOM }, "superbagof no" ); check_test( sub { cmp_deeply(['b', 'a', 'b'], subbagof('a', 'b', 'c', 'a', 'a', 'b' )); }, { actual_ok => 1, diag => "", }, "subbagof yes" ); check_test( sub { cmp_deeply(['d', 'b', 'd','b'], subbagof('a', 'b', 'c', 'a')); }, { actual_ok => 0, diag => <<'EOM', Comparing $data as a SubBag Extra: 'b', 'd', 'd' EOM }, "subbagof no" ); { check_test( sub { cmp_deeply(['a', 'a', 'b', 'c', 'b'], noneof('d', 'e', 'f')); }, { actual_ok => 1, diag => "", }, "noneof yes" ); check_test( sub { cmp_deeply(['a', 'a', 'b', 'c', 'b'], noneof('b', 'c', 'd', 'e')); }, { actual_ok => 0, diag => <<'EOM', Comparing $data as a NoneOf Extra: 'b', 'c' EOM }, "noneof no" ); } eval { my @res = run_tests( sub { cmp_bag([], {}) } ) }; like($@, qr/Argument 2 to cmp_bag is not an ARRAY ref $HASH.$/, "check arg 1") } PK��[ ��memory.tnu��[��use strict; use warnings; use Test::Tester; use Test::More; BEGIN { require Scalar::Util; if (grep /^weaken$/, @Scalar::Util::EXPORT_FAIL) { plan(skip_all => "no weak refs in this version of perl"); exit(0); } }use lib 't/lib'; use Std; use Scalar::Util qw( isweak weaken); sub left { my $ref = shift; eq_deeply($ref, []); return "left"; } sub right { my $ref = shift; eq_deeply([], $ref); return "right"; } my @subs = (\&left, \&right); for my $sub (@subs) { my $ref = []; my $weak = $ref; weaken($weak); my $side = &$sub($ref, []); $ref = 1; ok((! $weak), "$side didn't capture") \|\| diag "weak = $weak"; } PK��[��e�� shallow.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { my $a = {}; check_test( sub { cmp_deeply([$a, ["b"]], [shallow($a), ["b"]]); }, { actual_ok => 1, diag => "", }, "shallow eq" ); my $b = []; check_test( sub { cmp_deeply([$a, ["b"]], [shallow($b), ["b"]]); }, { actual_ok => 0, diag => <<EOM, Compared \$data->[0] got : $a expect : $b EOM }, "shallow not eq" ); check_test( sub { cmp_deeply([$a."", ["b"]], [shallow($a), ["b"]]); }, { actual_ok => 0, diag => <<EOM, Compared \$data->[0] got : '$a' expect : $a EOM }, "shallow not eq" ); check_test( sub { cmp_deeply([$a, ["b"]], [shallow($a), ["a"]]); }, { actual_ok => 0, diag => <<EOM, Compared \$data->[1][0] got : 'b' expect : 'a' EOM }, "deep after shallow not eq" ); } { my $u = shallow(undef); check_tests( sub { cmp_deeply(undef, $u); cmp_deeply("a", $u); cmp_deeply("a", $u); cmp_deeply("a", undef); }, [ { actual_ok => 1, }, { actual_ok => 0, }, { actual_ok => 0, }, { actual_ok => 0, }, ], "deep after shallow not eq" ); } PK��[/�i��array.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_test( sub { cmp_deeply(["a", "b"], ["a", "b"], "array eq"); }, { name => "array eq", actual_ok => 1, diag => "", } ); check_test( sub { cmp_deeply(["a", "b"], ["a", "c"], "array not eq"); }, { name => "array not eq", actual_ok => 0, diag => <<EOM, Compared \$data->[1] got : 'b' expect : 'c' EOM } ); check_test( sub { cmp_deeply(["a", "b"], ["a"], "array got DNE"); }, { name => "array got DNE", actual_ok => 0, diag => <<EOM, Compared array length of \$data got : array with 2 element(s) expect : array with 1 element(s) EOM } ); check_test( sub { cmp_deeply(["a"], ["a", "b"], "array expected DNE"); }, { name => "array expected DNE", actual_ok => 0, diag => <<EOM, Compared array length of \$data got : array with 1 element(s) expect : array with 2 element(s) EOM } ); check_tests( sub { cmp_deeply([[1]], [[1, 2]]); }, [ { actual_ok => 0, diag => <<EOM, Compared array length of \$data->[0] got : array with 1 element(s) expect : array with 2 element(s) EOM }, ], "deep bad length" ); } PK��[��H1��1��leaf-wrapper.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_test( sub { cmp_deeply( Test::Deep::EqOverloaded->new, 5); }, { actual_ok => 0, }, "comparing a plain scalar leaf against obj without eq" ); { local $Test::Deep::LeafWrapper = \&str; check_tests( sub { cmp_deeply( Test::Deep::EqOverloaded->new, 5); cmp_deeply( Test::Deep::EqOverloaded->new, 6); }, [ { actual_ok => 1, }, { actual_ok => 0, }, ], "comparing a plain scalar leaf against obj with eq" ); } { check_tests( sub { my $t1 = 5; my $t2 = any(5); my $t3 = all(5); local $Test::Deep::LeafWrapper = \&str; cmp_deeply(Test::Deep::EqOverloaded->new, $t1); cmp_deeply(Test::Deep::EqOverloaded->new, $t2); cmp_deeply(Test::Deep::EqOverloaded->new, $t3); }, [ { actual_ok => 1, }, { actual_ok => 1, }, { actual_ok => 1, }, ], "comparing a plain scalar leaf against obj with eq via any() and all()" ); } } { package Test::Deep::EqOverloaded; use overload q{""} => sub { "5" }, fallback => 1; sub new { my $self = {}; bless $self; } } PK��[v�� 0��0��class.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { my $bless_a = bless {}, "A::Class"; my $bless_b = bless {}, "B::Class"; my $nobless = {}; check_test( sub { cmp_deeply([$bless_a], [noclass($bless_b)]); }, { actual_ok => 1, diag => "", }, "no class eq" ); check_test( sub { cmp_deeply([$bless_a], [noclass($nobless)]); }, { actual_ok => 1, diag => "", }, "no class eq unblessed" ); check_test( sub { cmp_deeply([$bless_a], [$bless_b]); }, { actual_ok => 0, diag => <<EOM, Compared blessed(\$data->[0]) got : 'A::Class' expect : 'B::Class' EOM }, "class not eq" ); check_test( sub { cmp_deeply([$bless_a], [$nobless]); }, { actual_ok => 0, diag => <<EOM, Compared blessed(\$data->[0]) got : 'A::Class' expect : undef EOM }, "class not eq unblessed" ); my $bless_c = bless [$bless_a], "C::Class"; check_test( sub { cmp_deeply( $bless_c, bless([noclass($nobless)], "C::Class") ); }, { actual_ok => 1, diag => "", }, "class eq on/off" ); my $bless_d = bless [$bless_c], "D::Class"; check_test( sub { cmp_deeply( $bless_d, bless([noclass(bless([useclass(bless({}, "NotA::Class"))], "NotC::Class"))], "D::Class"), ); }, { actual_ok => 0, diag => <<EOM, Compared blessed(\$data->[0]->[0]) got : 'A::Class' expect : 'NotA::Class' EOM }, "class eq on/off/on" ); } PK��[�8C��cache.tnu��[��use strict; use warnings; use Test::More 0.88; use if $ENV{AUTHOR_TESTING}, 'Test::Warnings'; use Test::Deep::Cache; { local $Test::Deep::Expects = 0; my $cache = Test::Deep::Cache->new; my $a = \"a"; my $b = \"b"; my $c = []; ok(! $cache->cmp($a, $b), "empty cache"); $cache->add($a, $b); ok($cache->cmp($a, $b), "added"); ok($cache->cmp($b, $a), "reverse"); $cache->local; ok($cache->cmp($a, $b), "after local"); $cache->add($b, $c); ok($cache->cmp($b, $c), "local added"); $cache->finish(0); ok(! $cache->cmp($b, $c), "gone"); $cache->local; $cache->add($b, $c); ok($cache->cmp($b, $c), "local added again"); $cache->finish(1); ok($cache->cmp($b, $c), "still there"); } done_testing; PK��[>�Q�� reftype.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_test( sub { cmp_deeply([], reftype("ARRAY")); }, { actual_ok => 1, diag => '', }, "ARRAY ok" ); check_test( sub { cmp_deeply([], reftype("HASH")); }, { actual_ok => 0, diag => <<EOM, Compared reftype(\$data) got : 'ARRAY' expect : 'HASH' EOM }, "ARRAY" ); } PK��[�×�� listmethods.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; foreach my $thing (fake->new, 'fake') { check_test( sub { cmp_deeply($thing, listmethods(meth1 => ["val1"], meth2 => ['a', 'b'])); }, { actual_ok => 1, diag => "", }, "listmethods eq" ); check_test( sub { cmp_deeply($thing, listmethods(meth1 => ["val1"], meth2 => ['a', 'c'])); }, { actual_ok => 0, diag => <<EOM, Compared [\$data->meth2]->[1] got : 'b' expect : 'c' EOM }, "listmethods not eq" ); check_test( sub { cmp_deeply($thing, listmethods(['plus1', 2] => ["a", "a", "a"])); }, { actual_ok => 1, diag => "", }, "listmethods arg eq" ); check_test( sub { cmp_deeply($thing, listmethods(['plus1', 2] => ["a", "b", "a"])); }, { actual_ok => 0, diag => <<EOM, Compared [\$data->plus1(2)]->[1] got : 'a' expect : 'b' EOM }, "listmethods arg not eq" ); my $v3 = ['val3']; check_test( sub { cmp_deeply($thing, listmethods(meth1 => ["val1"], meth3 => $v3)); }, { actual_ok => 0, diag => <<EOM, Compared [\$data->meth3] got : Does not exist expect : $v3 EOM }, "listmethods DNE" ); } { my $obj = fake->new; check_test( sub { cmp_deeply( { key => [ \"a", \["b"], \$obj ] }, { key => [ \"a", \["b"], \(listmethods(meth1 => ["val1"], meth2 => ['a', 'b'])) ] } ); }, { actual_ok => 1, diag => "", }, "complex eq" ); check_test( sub { cmp_deeply( { key => [ \"a", \["b"], \$obj ] }, { key => [ \"a", \["b"], \(listmethods(meth1 => ["val1"], meth2 => ['a', 'c'])) ] } ); }, { actual_ok => 0, diag => <<EOM, Compared [\${\$data->{"key"}[2]}->meth2]->[1] got : 'b' expect : 'c' EOM }, "complex not eq" ); } package fake; sub new { return bless {}, __PACKAGE__; } sub meth1 { return "val1"; } sub meth2 { return ('a', 'b'); } sub plus1 { my $self = shift; my $arg = shift; return ("a") x ($arg + 1); } PK��[�shC��C��hash_each.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { my $re = qr/^wi/; check_test( sub { cmp_deeply( { a => 'wine', b => 'wind', c => 'wibble'}, hash_each( re($re) ) ) }, { actual_ok => 1, diag => "", }, "hash_each eq" ); check_test( sub { cmp_deeply( { a => 'wine', b => 'wand', c => 'wibble'}, hash_each( re($re) ) ) }, { actual_ok => 0, diag => <<EOM, Using Regexp on \$data->{"b"} got : 'wand' expect : $re EOM }, "hash_each not eq" ); } PK��[iX>��>��string.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_test( sub { cmp_deeply("wine", str("wine")) }, { actual_ok => 1, diag => "", }, "string eq" ); check_test( sub { cmp_deeply("wine", str("wind")) }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a string got : 'wine' expect : 'wind' EOM }, "string not eq" ); } { require Over; my $o = Over->new("wine"); check_test( sub { cmp_deeply($o, str("wine")) }, { actual_ok => 1, diag => "", }, "over string eq" ); check_test( sub { cmp_deeply($o, str("wind")) }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a string got : 'wine' expect : 'wind' EOM }, "over string not eq" ); } PK��[d��}��}��isa.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { my $a = {}; check_test( sub { cmp_deeply($a, isa("HASH")); }, { actual_ok => 1, diag => "", }, "isa eq" ); check_test( sub { cmp_deeply($a, obj_isa("HASH")); }, { actual_ok => 0, diag => <<EOM, Checking class of \$data with isa() got : $a expect : blessed into 'HASH' or subclass of 'HASH' EOM }, "obj_isa eq" ); } { my $b = bless {}, "B"; check_test( sub { cmp_deeply($b, isa("B")); }, { actual_ok => 1, diag => "", }, "isa eq" ); check_test( sub { cmp_deeply($b, obj_isa("B")); }, { actual_ok => 1, diag => "", }, "isa eq" ); check_test( sub { cmp_deeply($b, isa("A")); }, { actual_ok => 0, diag => <<EOM, Checking class of \$data with isa() got : $b expect : blessed into or ref of type 'A' EOM }, "isa eq" ); check_test( sub { cmp_deeply($b, obj_isa("A")); }, { actual_ok => 0, diag => <<EOM, Checking class of \$data with isa() got : $b expect : blessed into 'A' or subclass of 'A' EOM }, "isa eq" ); @A::ISA = (); @B::ISA = ("A"); check_test( sub { cmp_deeply($b, isa("A")); }, { actual_ok => 1, diag => "", }, "isa eq" ); check_test( sub { cmp_deeply($b, obj_isa("A")); }, { actual_ok => 1, diag => "", }, "isa eq" ); } package A; use Test::Deep; @A::ISA = qw( Test::Deep ); { ::ok(A->isa("Test::Deep"), "U::isa says yes"); ::ok(! A->isa("Test"), "U::isa says yes"); } { package C; use base 'A'; } package main; { my $c = bless {}, "C"; check_test( sub { cmp_deeply($c, isa("A")); }, { actual_ok => 1, diag => "", }, "isa eq" ); } PK��[7ݮc��no-clobber-globals.tnu��[��use strict; use warnings; use lib 't/lib'; use Test::Deep; use Test::More 0.88; { $@ = 'hello'; any(123); is($@, 'hello', q{dynamically loaded test doesn't overwrite $@} ); } { $! = 11; all(123); is( 0 + $!, 11, q{dynamically loaded test doesn't overwrite $!} ); } { $^E = 11; re(qr{a}); is( 0 + $^E, 11, q{dynamically loaded test doesn't overwrite $^E} ); } { $@ = 'hello'; cmp_deeply( 'hello', str($@), 'when passing $@ to str() it is not localized away from new' ); } done_testing; PK��[�H��bagrecursion.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; # just want to make sure this doesn't go into an infitite recursion my @methods=(methods(hello=>'world'),methods(goodbye=>'world')); my $bag_o_methods=bag(@methods); ok(1, "no inifinite recursion"); PK��[}[�B�� regexp.t.orignu��[��use strict; use warnings; use t::std; { my $str = "ferg"; my $re = qr/$str/; check_test( sub { cmp_deeply("fergal", re($re)); }, { actual_ok => 1, diag => "", }, "re eq" ); check_test( sub { cmp_deeply("feargal", re($re)); }, { actual_ok => 0, diag => <<EOM, Using Regexp on \$data got : 'feargal' expect : $re EOM }, "re not eq" ); check_test( sub { cmp_deeply("fergal", re($str)); }, { actual_ok => 1, diag => "", }, "string re eq" ); check_test( sub { cmp_deeply("feargal", re($str)); }, { actual_ok => 0, diag => <<EOM, Using Regexp on \$data got : 'feargal' expect : $re EOM }, "string runre not eq" ); } PK��[Qʐ�F��F�� hashkeys.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_tests( sub { cmp_deeply({}, hashkeys(), "0"); cmp_deeply({1 => 2, 3 => 4, 5 => 6}, hashkeys(1, 3, 5), "3"); }, [ { name => "0", actual_ok => 1, diag => "", }, { name => "3", actual_ok => 1, diag => "", } ], "keys ok" ); check_tests( sub { cmp_deeply({a => 2, b => 4}, hashkeys("a", "c")); }, [ { actual_ok => 0, diag => <<EOM, Comparing hash keys of \$data Missing: 'c' Extra: 'b' EOM }, ], "bad length" ); check_tests( sub { cmp_deeply("a", hashkeys(1), "string"); cmp_deeply([], hashkeys(1), "array"); }, [ { name => "string", actual_ok => 0, diag => <<EOM, Compared reftype(\$data) got : undef expect : 'HASH' EOM }, { name => "array", actual_ok => 0, diag => <<EOM, Compared reftype(\$data) got : 'ARRAY' expect : 'HASH' EOM }, ], "not array" ); } PK��[��{ �� array_each.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { my $re = qr/^wi/; check_test( sub { cmp_deeply([qw( wine wind wibble winny window )], array_each( re($re) )) }, { actual_ok => 1, diag => "", }, "array_each eq" ); check_test( sub { cmp_deeply([qw( wibble wobble winny window )], array_each( re($re) )) }, { actual_ok => 0, diag => <<EOM, Using Regexp on \$data->[1] got : 'wobble' expect : $re EOM }, "array_each not eq" ); } PK��[۽;.��number.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_test( sub { cmp_deeply(1, num(1)); }, { actual_ok => 1, diag => "", }, "number eq" ); check_test( sub { cmp_deeply(1, num(2)) }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a number got : 1 expect : 2 EOM }, "number not eq" ); check_test( sub { cmp_deeply("1a", num("1")) }, { actual_ok => 1, diag => "", }, "funny number eq" ); check_test( sub { cmp_deeply("1a", num(2)) }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a number got : 1 ('1a') expect : 2 EOM }, "funny number not eq" ); } { check_test( sub { cmp_deeply(1, num(1, 1)); }, { actual_ok => 1, diag => "", }, "number tolerance eq" ); check_test( sub { cmp_deeply(1, num(2, .5)) }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a number got : 1 expect : 2 +/- 0.5 EOM }, "number tolerance not eq" ); } { require Over; my $o = Over->new(1); check_test( sub { cmp_deeply($o, num(1)) }, { actual_ok => 1, diag => "", }, "over number eq" ); check_test( sub { cmp_deeply($o, num(2)) }, { actual_ok => 0, diag => <<EOM, Comparing \$data as a number got : 1 expect : 2 EOM }, "over number not eq" ); } PK��[�j��j�� descend.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_test( sub { cmp_deeply("a", "a", "scalar eq"); }, { name => "scalar eq", actual_ok => 1, diag => "", } ); check_test( sub { cmp_deeply("a", "b", "scalar not eq"); }, { name => "scalar not eq", actual_ok => 0, diag => <<EOM, Compared \$data got : 'a' expect : 'b' EOM } ); check_test( sub { cmp_deeply("a", undef, "def undef"); }, { name => "def undef", actual_ok => 0, diag => <<EOM, Compared \$data got : 'a' expect : undef EOM } ); check_test( sub { cmp_deeply(undef, "a", "undef def"); }, { name => "undef def", actual_ok => 0, diag => <<EOM, Compared \$data got : undef expect : 'a' EOM } ); check_test( sub { cmp_deeply(undef, undef, "undef undef"); }, { name => "undef undef", actual_ok => 1, diag => '', } ); check_test( sub { cmp_deeply("", undef); }, { actual_ok => 0, diag => <<EOM, Compared \$data got : '' expect : undef EOM }, "scalar undef and blank" ); } { check_test( sub { cmp_deeply(\\"a", \\"a", "ref ref eq"); }, { name => "ref ref eq", actual_ok => 1, diag => "", } ); check_test( sub { cmp_deeply(\\"a", \\"b", "ref ref not eq"); }, { name => "ref ref not eq", actual_ok => 0, diag => <<EOM, Compared \${\${\$data}} got : 'a' expect : 'b' EOM } ); } { my @a; check_test( sub { cmp_deeply(\@a, \@a); }, { actual_ok => 1, diag => "", }, "equal refs" ); } { my @a; check_test( sub { cmp_deeply(undef, \@a); }, { actual_ok => 0, }, "not calling StrVal on undef" ); } PK��[ xy@�� circular.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { my $a1 = gen_layers(2); my $a2 = gen_layers(2); check_test( sub { cmp_deeply($a1, $a2); }, { actual_ok => 1, diag => "", }, "2 layers" ); push(@$a1, "break"); check_test( sub { cmp_deeply($a1, $a2); }, { actual_ok => 0, diag => <<EOM, Compared array length of \$data got : array with 4 element(s) expect : array with 3 element(s) EOM }, "2 layers broken" ); push(@$a2, "break"); check_test( sub { cmp_deeply($a1, $a2); }, { actual_ok => 1, diag => "", }, "2 layers fixed" ); } { my $a1 = gen_layers(2); my $a2 = gen_layers(3); check_test( sub { cmp_deeply($a1, $a2); }, { actual_ok => 1, diag => "", }, "2 and 3 layers" ); push(@$a1, "break"); check_test( sub { cmp_deeply($a1, $a2); }, { actual_ok => 0, diag => <<EOM, Compared array length of \$data got : array with 4 element(s) expect : array with 3 element(s) EOM }, "2 and 3 layers broken" ); push(@$a2, "break"); check_test( sub { cmp_deeply($a1, $a2); }, { actual_ok => 0, diag => <<EOM, Compared array length of \$data->[2][2] got : array with 4 element(s) expect : array with 3 element(s) EOM }, "2 and 3 layers not fixed" ); } { my $a1 = gen_interleave(); my $a2 = gen_interleave(); check_test( sub { cmp_deeply($a1, $a2); }, { actual_ok => 1, diag => "", }, "interleave" ); } sub gen_layers { my $num = shift; my $first = ['text', gen_circle()]; $num--; my $last = $first; while ($num--) { my $next = ['text', gen_circle()]; push(@$last, $next); $last = $next; } push(@$last, $first); return $first } sub gen_circle { my $a = ['circle']; push(@$a, $a); return $a } sub gen_interleave { my $a = []; my $b = []; push(@$a, $b, $a); push(@$b, $a, $b); return $a; } PK��[��i�t��t��import.tnu��[��use strict; use warnings; use Test::More tests => 2; use Test::Deep 'all'; ok(defined &all); ok(! defined &any); PK��[�:5��all.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_test( sub { cmp_deeply(["wine"], all( [re(qr/^wi/)], [re(qr/ne$/)], ["wine"]) ) }, { actual_ok => 1, diag => "", }, "all eq" ); check_test( sub { cmp_deeply(["wine"], all( [re(qr/^wi/)], [re(qr/ne$/)], ["wines"]) ) }, { actual_ok => 0, diag => <<EOM, Compared (Part 3 of 3 in \$data)->[0] got : 'wine' expect : 'wines' EOM }, "all not eq" ); check_tests( sub { cmp_deeply("wine", all(re("^wi")) & re('ne$'), "pass"); cmp_deeply("wine", all(re("^wi")) & re('na$'), "fail"); }, [ {actual_ok => 1}, {actual_ok => 0} ], "all with &" ); check_tests( sub { cmp_deeply("wine", re("^wi") & re('ne$'), "pass"); cmp_deeply("wine", re("^wi") & re('na$'), "fail"); }, [ {actual_ok => 1, diag => ""}, {actual_ok => 0} ], "& without all" ); } PK��[yx��regexpref.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; my $xism = qr/x/=~/\(\?\^/ ? "^" : "-xism"; { check_test( sub { cmp_deeply(qr/a/, qr/a/, "regexp ref eq"); }, { name => "regexp ref eq", actual_ok => 1, diag => "", } ); check_test( sub { cmp_deeply(qr/a/, qr/b/, "regexp ref not eq"); }, { name => "regexp ref not eq", actual_ok => 0, diag => <<EOM, Compared m/\$data/ got : (?$xism:a) expect : (?$xism:b) EOM } ); } PK��[��hash.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_test( sub { cmp_deeply({key1 => "a", key2 => "b"}, {key1 => "a", key2 => "b"}, "hash eq"); }, { name => "hash eq", actual_ok => 1, diag => "", } ); check_test( sub { cmp_deeply({key1 => "a", key2 => "b"}, {key1 => "a", key2 => "c"}, "hash not eq"); }, { name => "hash not eq", actual_ok => 0, diag => <<EOM, Compared \$data->{"key2"} got : 'b' expect : 'c' EOM } ); check_test( sub { cmp_deeply({key1 => "a"}, {key1 => "a", key2 => "c"}, "hash got DNE"); }, { name => "hash got DNE", actual_ok => 0, diag => <<EOM, Comparing hash keys of \$data Missing: 'key2' EOM } ); check_test( sub { cmp_deeply({key1 => "a", key2 => "c"}, {key1 => "a"}, "hash expected DNE"); }, { name => "hash expected DNE", actual_ok => 0, diag => <<EOM, Comparing hash keys of \$data Extra: 'key2' EOM } ); check_test( sub { cmp_deeply({key1 => "a", key2 => "c"}, superhashof({key1 => "a"}), "superhash ok"); }, { name => "superhash ok", actual_ok => 1, diag => "", } ); check_test( sub { cmp_deeply({key1 => "a"}, subhashof({key1 => "a", key2 => "c"}), "subhash ok"); }, { name => "subhash ok", actual_ok => 1, diag => "", } ); } PK��[@Ֆ�[��[��notest_withtest.tnu��[��use strict; use warnings; { package Foo; use Test::Deep::NoTest; sub check_this { return eq_deeply($_[1], []); } } use Test::More 0.88; use if $ENV{AUTHOR_TESTING}, 'Test::Warnings'; use Test::Deep; ok(Foo->check_this([]), 'notest 1'); ok(! Foo->check_this({}), 'notest 2'); cmp_deeply([], [], 'got cmp_deeply'); done_testing; PK��[ �ӳ��scalarref.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_test( sub { cmp_deeply(\"a", \"a", "scalar ref eq"); }, { name => "scalar ref eq", actual_ok => 1, diag => "", } ); check_test( sub { cmp_deeply(\"a", \"b", "scalar ref not eq"); }, { name => "scalar ref not eq", actual_ok => 0, diag => <<EOM, Compared \${\$data} got : 'a' expect : 'b' EOM } ); check_test( sub { cmp_deeply({}, \"a", "scalar ref not ref"); }, { name => "scalar ref not ref", actual_ok => 0, diag => <<EOM, Compared reftype(\$data) got : 'HASH' expect : 'SCALAR' EOM } ); } PK��[�s��scalar.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { my $a = []; check_test( sub { cmp_deeply($a."", $a); }, { actual_ok => 0, diag => <<EOM, Compared reftype(\$data) got : undef expect : 'ARRAY' EOM }, "stringified ref not eq" ); check_test( sub { cmp_deeply(undef, ""); }, { actual_ok => 0, diag => <<EOM, Compared \$data got : undef expect : '' EOM }, "undef ne ''" ); check_test( sub { cmp_deeply([$a."", ["b"]], [shallow($a), ["b"]]); }, { actual_ok => 0, diag => <<EOM, Compared \$data->[0] got : '$a' expect : $a EOM }, "shallow not eq" ); check_test( sub { cmp_deeply([$a, ["b"]], [shallow($a), ["a"]]); }, { actual_ok => 0, diag => <<EOM, Compared \$data->[1][0] got : 'b' expect : 'a' EOM }, "deep after shallow not eq" ); } PK��[�p�[��[�� arraylength.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_tests( sub { cmp_deeply([], arraylength(0), "0"); cmp_deeply([1..3], arraylength(3), "3"); }, [ { name => "0", actual_ok => 1, diag => "", }, { name => "3", actual_ok => 1, diag => "", } ], "len ok" ); check_tests( sub { cmp_deeply({}, arraylength(2)); }, [ { actual_ok => 0, diag => <<EOM, Compared reftype(\$data) got : 'HASH' expect : 'ARRAY' EOM }, ], "bad reftype" ); check_tests( sub { cmp_deeply([1], arraylength(2)); }, [ { actual_ok => 0, diag => <<EOM, Compared array length of \$data got : array with 1 element(s) expect : array with 2 element(s) EOM }, ], "bad length" ); check_tests( sub { cmp_deeply("a", arraylength(0), "string"); cmp_deeply({}, arraylength(0), "hash"); }, [ { name => "string", actual_ok => 0, diag => <<EOM, Compared reftype(\$data) got : undef expect : 'ARRAY' EOM }, { name => "hash", actual_ok => 0, diag => <<EOM, Compared reftype(\$data) got : 'HASH' expect : 'ARRAY' EOM }, ], "not array" ); check_tests( sub { cmp_deeply([[1]], [arraylength(2)]); }, [ { actual_ok => 0, diag => <<EOM, Compared array length of \$data->[0] got : array with 1 element(s) expect : array with 2 element(s) EOM }, ], "deep bad length" ); } PK��[u�ϣ��notest_extra.tnu��[��use strict; use warnings; use Test::More 0.88; use if $ENV{AUTHOR_TESTING}, 'Test::Warnings'; use Test::Deep::NoTest; ok(eq_deeply([], []), "got eq_deeply"); ok(! eq_deeply({}, []), "eq_deeply works"); done_testing; PK��[��notest.tnu��[��use strict; use warnings; use Test::Deep::NoTest; # make sure we didn't load Test::Builder my $ok = not exists( ${Test::Builder::}{"new"}); print "1..1\n"; print $ok ? "" : "not "; print "ok 1\n"; PK��[Ʃb�� lib/Std.pmnu��[��use strict; use warnings; use Test::Tester; use Test::More 0.88; use if $ENV{AUTHOR_TESTING}, 'Test::Warnings'; use Test::Deep; Test::Deep::builder(Test::Tester::capture()); END { done_testing; } 1; PK��[o��lib/Over.pmnu��[��use strict; use warnings; package Over; use overload '""' => \&val, '0+' => \&val, fallback => 1; sub new { my $pkg = shift; my $val = shift; return bless \$val, $pkg; } sub val { my $self = shift; return $$self; } 1; PK��[�\|��-��-��deep_utils.tnu��[��use strict; use warnings; use Test::More 0.88; use if $ENV{AUTHOR_TESTING}, 'Test::Warnings'; use Test::Deep qw( cmp_deeply descend render_stack methods deep_diag ); { my $a = []; my $base = Test::Deep::_td_reftype($a); is($base, "ARRAY", "_td_reftype base ref"); } { my $a = bless [], "A::Class"; my $base = Test::Deep::_td_reftype($a); is($base, "ARRAY", "_td_reftype base obj"); } { my $a = qr/a/; my $base = Test::Deep::_td_reftype($a); is($base, ($] < 5.011 ? "Regexp" : "REGEXP"), "class_base base regexp"); } done_testing; PK��['j/6��6��rt78288_blessed_object.tnu��[��use strict; use warnings FATAL => 'all'; use lib 't/lib'; use Std; check_test( sub { cmp_deeply('Foo', isa('Foo')) }, { actual_ok => 0, diag => <<EOM, Checking class of \$data with isa() got : 'Foo' expect : blessed into or ref of type 'Foo' EOM }, 'isa on a string' ); PK��[lgo�� methods.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; foreach my $thing (fake->new, 'fake') { check_test( sub { cmp_deeply($thing, methods(meth1 => "val1", meth2 => ['a', 'b'])); }, { actual_ok => 1, diag => "", }, "methods eq" ); check_test( sub { cmp_deeply($thing, methods(meth1 => "val1", meth2 => ['a', 'c'])); }, { actual_ok => 0, diag => <<EOM, Compared \$data->meth2->[1] got : 'b' expect : 'c' EOM }, "methods not eq" ); check_test( sub { cmp_deeply($thing, methods(['plus1', 2] => 3)); }, { actual_ok => 1, diag => "", }, "methods arg eq" ); check_test( sub { cmp_deeply($thing, methods(['plus1', 2] => 2)); }, { actual_ok => 0, diag => <<EOM, Compared \$data->plus1(2) got : '3' expect : '2' EOM }, "methods arg not eq" ); check_test( sub { cmp_deeply($thing, methods(meth1 => "val1", meth3 => "val3")); }, { actual_ok => 0, diag => <<EOM, Compared \$data->meth3 got : Does not exist expect : 'val3' EOM }, "methods DNE" ); } { my $obj = fake->new; check_test( sub { cmp_deeply( { key => [ \"a", \["b"], \$obj ] }, { key => [ \"a", \["b"], \(methods(meth1 => "val1", meth2 => ['a', 'b'])) ] } ); }, { actual_ok => 1, diag => "", }, "complex eq" ); check_test( sub { cmp_deeply( { key => [ \"a", \["b"], \$obj ] }, { key => [ \"a", \["b"], \(methods(meth1 => "val1", meth2 => ['a', 'c'])) ] } ); }, { actual_ok => 0, diag => <<EOM, Compared \${\$data->{"key"}[2]}->meth2->[1] got : 'b' expect : 'c' EOM }, "complex not eq" ); check_test( sub { cmp_methods($obj, [meth1 => "val1", meth2 => ['a', 'b']]); }, { actual_ok => 1, diag => "", }, "methods eq" ); check_test( sub { cmp_methods($obj, [meth1 => "val1", meth2 => ['a', 'c']]); }, { actual_ok => 0, }, "methods not eq" ); } package fake; sub new { return bless {}, __PACKAGE__; } sub meth1 { return "val1"; } sub meth2 { return ['a', 'b']; } sub plus1 { my $self = shift; my $arg = shift; return $arg + 1; } PK��[�g��ignore.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_test( sub { cmp_deeply([[{}, "argh"], ["b"]], [ignore(), ["b"]]); }, { actual_ok => 1, diag => "", }, "ignore" ); } PK��[��Ϧ��any.tnu��[��use strict; use warnings; use lib 't/lib'; use Std; { check_test( sub { cmp_deeply("wine", any("beer", "wine")) }, { actual_ok => 1, diag => "", }, "any eq" ); check_test( sub { cmp_deeply("whisky", any("beer", "wine")) }, { actual_ok => 0, diag => <<EOM, Comparing \$data with Any got : 'whisky' expected : Any of ( 'beer', 'wine' ) EOM }, "any not eq" ); check_test( sub { cmp_deeply("whisky", any("beer") \| "wine") }, { actual_ok => 0, diag => <<EOM, Comparing \$data with Any got : 'whisky' expected : Any of ( 'beer', 'wine' ) EOM }, "any with \|" ); check_tests( sub { cmp_deeply("whisky", re("isky") \| "wine", "pass"); cmp_deeply("whisky", re("iskya") \| "wine", "fail") }, [ { actual_ok => 1 }, { actual_ok => 0 } ], "\| without any" ); } PK��[��2��05_success.tnu��Iw��use strict; use warnings; use Test::More tests => 1; use Test::Requires; test_requires 'Scalar::Util'; test_requires 'Data::Dumper'; test_requires 'Devel::Peek'; like Dumper("HOGE"), qr/\$VAR/; PK��[��02_no_plan.tnu��Iw��BEGIN { $ENV{RELEASE_TESTING} = 0 }; use strict; use warnings; use Test::More 'no_plan'; use Test::Requires; test_requires 'Acme::Unknown::Missing::Module::Name'; fail 'do not reach here'; PK��[�D��03_import_hashref.tnu��Iw��BEGIN { $ENV{RELEASE_TESTING} = 0 }; use strict; use warnings; use Test::More; use Test::Requires { 'Scalar::Util' => 0.02, 'Acme::Unknown::Missing::Module::Name' => 0.01, }; fail 'do not reach here'; PK��[�ˀ��04_import_array.tnu��Iw��BEGIN { $ENV{RELEASE_TESTING} = 0 }; use strict; use warnings; use Test::More; use Test::Requires qw( Acme::Unknown::Missing::Module::Name ); plan tests => 3; fail 'do not reach here'; PK��[��01_simple.tnu��Iw��BEGIN { $ENV{RELEASE_TESTING} = 0 }; use strict; use warnings; use Test::More tests => 10; use Test::Requires; test_requires 'Acme::Unknown::Missing::Module::Name'; fail 'do not reach here'; PK��[�yY��06_perlver.tnu��Iw��BEGIN { $ENV{RELEASE_TESTING} = 0 }; use strict; use warnings; use Test::More 'no_plan'; use Test::Requires; test_requires '5.005'; test_requires 'v5.5'; pass 'should reach here'; unless ($] > 5.998) { test_requires '5.999'; fail 'do not reach here'; } PK��&�[ �^��^��appconfig.tnu��[��#!/usr/bin/perl -w #======================================================================== # # t/appconfig.t # # AppConfig test file. # # Written by Andy Wardley <abw@cre.canon.co.uk> # # Copyright (C) 1998 Canon Research Centre Europe Ltd. # All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use vars qw($loaded); BEGIN { $\| = 1; print "1..9\n"; } END { ok(0) unless $loaded; } my $ok_count = 1; sub ok { shift or print "not "; print "ok $ok_count\n"; ++$ok_count; } use AppConfig qw(:argcount); $loaded = 1; ok(1); #------------------------------------------------------------------------ # define a new AppConfig object # my $default = "<default>"; my $anon = "<anon>"; my $noage = "<unborn>"; my $config = AppConfig->new({ GLOBAL => { DEFAULT => $default, ARGCOUNT => ARGCOUNT_ONE, } }, 'verbose', { DEFAULT => 0, ARGCOUNT => ARGCOUNT_NONE, }, 'user', { ALIAS => 'name\|uid', DEFAULT => $anon, }); $config->define( 'age', { DEFAULT => $noage, VALIDATE => '\d+', }); #------------------------------------------------------------------------ # check and manipulate variables # #2: check config got defined ok( defined $config ); #3 - #5: check variables were defined ok( $config->verbose() == 0 ); ok( $config->user() eq $anon ); ok( $config->age() eq $noage ); #6: read config file at DATA handle ok( $config->file(\DATA) ); #7 - #9: check values got updated correctly ok( $config->verbose() == 1 ); ok( $config->user() eq 'abw' ); ok( $config->age() == 42 ); __DATA__ verbose = 1 user = abw age = 42 PK��&�[�,)��novars.tnu��[��#!/usr/bin/perl -w #======================================================================== # # t/novars.t # # AppConfig::State test file testing negative setting of flag options # with "no<var>" syntax. # # Written by Andy Wardley <abw@cre.canon.co.uk> # # Copyright (C) 1998 Canon Research Centre Europe Ltd. # All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #------------------------------------------------------------------------ # # TODO # # * test PEDANTIC option # #======================================================================== use strict; use vars qw($loaded); BEGIN { $\| = 1; print "1..18\n"; } END { ok(0) unless $loaded; } my $ok_count = 1; sub ok { shift or print "not "; print "ok $ok_count\n"; ++$ok_count; } use AppConfig qw(:argcount); use AppConfig::State; $loaded = 1; ok(1); #------------------------------------------------------------------------ # create new AppConfig::State and AppConfig::Args objects # my $state = AppConfig::State->new( 'verbose' => { DEFAULT => 0, ARGCOUNT => ARGCOUNT_NONE, ALIAS => 'v', }, 'debug' => { ALIAS => 'dbg\|d', # should default ARGCOUNT to ARGCOUNT_NONE }, 'age' => { ALIAS => 'a', ARGCOUNT => ARGCOUNT_ONE, }, 'nohope', ); #2: test the state got instantiated correctly ok( defined $state ); #3 - #6: update and check verbose ok( $state->verbose(1) ); ok( $state->verbose() == 1 ); ok( $state->noverbose(1) ); ok( $state->verbose() == 0 ); #7 - #15: update and check debug, also using aliases ok( $state->debug(1) ); ok( $state->debug() == 1 ); ok( $state->nodebug(1) ); ok( $state->debug() != 1 ); ok( $state->dbg(1) ); ok( $state->dbg() == 1 ); ok( $state->nodbg(1) ); ok( ! $state->dbg() ); ok( $state->nodbg() ); #16 - #17: attempt to update nohope and check it doesn't get interpreted # as "no - hope" ok( $state->nohope(1) ); ok( $state->nohope() == 1 ); #18: attempt to update noage which should fail because it doesn't # have an ARGCOUNT of ARGCOUNT_NONE $state->_ehandler( sub { } ); # disable errors ok( ! $state->noage(1) ); PK��&�[>�ӄ��cgi.tnu��[��#!/usr/bin/perl -w #======================================================================== # # t/cgi.t # # AppConfig::CGI test file. # # Written by Andy Wardley <abw@cre.canon.co.uk> # # Copyright (C) 1998 Canon Research Centre Europe Ltd. # All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use vars qw($loaded); BEGIN { $\| = 1; print "1..9\n"; } END { ok(0) unless $loaded; } my $ok_count = 1; sub ok { shift or print "not "; print "ok $ok_count\n"; ++$ok_count; } use AppConfig qw(:argcount); use AppConfig::CGI; $loaded = 1; ok(1); #------------------------------------------------------------------------ # create new AppConfig::State and AppConfig::CGI objects # my $default = "<default>"; my $anon = "<anon>"; my $user = "Fred Smith"; my $age = 42; my $notarg = "This is not an arg"; my $state = AppConfig::State->new({ GLOBAL => { DEFAULT => $default, ARGCOUNT => ARGCOUNT_ONE, } }, 'verbose' => { DEFAULT => 0, ARGCOUNT => ARGCOUNT_NONE, ALIAS => 'v', }, 'user' => { ALIAS => 'u\|name\|uid', DEFAULT => $anon, }, 'age' => { ALIAS => 'a', VALIDATE => '\d+', }); my $cfgcgi = AppConfig::CGI->new($state); #2 - #3: test the state and cfgargs got instantiated correctly ok( defined $state ); ok( defined $cfgcgi ); my $args = "v&u=$user&age=$age"; #4: process the args ok( $cfgcgi->parse($args) ); #5 - #7: check variables got updated ok( $state->verbose() == 1 ); ok( $state->user() eq $user ); ok( $state->age() == $age ); $age = $age * 2; #8 - #9: check args defaults to using $ENV{ QUERY_STRING } $ENV{ QUERY_STRING } = "v&u=$user=$user&age=$age"; ok( $cfgcgi->parse() ); ok( $state->age() == $age ); PK��&�[R]�� default.tnu��[��#!/usr/bin/perl -w #======================================================================== # # t/default.t # # AppConfig::File test file. Tests the '-option' syntax which is used # to reset variables to their default values. # # Written by Andy Wardley <abw@cre.canon.co.uk> # # Copyright (C) 1998 Canon Research Centre Europe Ltd. # All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use vars qw($loaded); use lib qw( ../lib ./lib ); use Test::More tests => 19; use AppConfig qw(:expand :argcount); ok(1, 'loaded'); #------------------------------------------------------------------------ # create new AppConfig # my $BAZDEF = "all_bar_none"; my $BAZNEW = "new_bar"; my $config = AppConfig->new( { GLOBAL => { ARGCOUNT => 0 } }, 'foo', 'bar', 'baz' => { ARGCOUNT => 1, DEFAULT => $BAZDEF }, 'qux' => { ARGCOUNT => 1 }, 'list' => { ARGCOUNT => ARGCOUNT_LIST, DEFAULT => [ 2, 3, 5, 7, 9 ], }, 'hash' => { ARGCOUNT => ARGCOUNT_HASH, DEFAULT => { two => 2, three => 3, five => 5 }, }, ); #2: test config got instantiated correctly ok( defined $config, 'defined config' ); #3 - #4: set some dummy values ok( $config->foo(1), 'got foo' ); ok( $config->baz($BAZNEW), 'baz new'); #5 - #6: test them ok( $config->foo() == 1, 'foo set' ); ok( $config->baz() eq $BAZNEW, 'baz set' ); #------------------------------------------------------------------------ # list #------------------------------------------------------------------------ my $list = $config->list(); ok( $list, 'got default list' ); ok( $list->[0] == 2, 'first item two' ); ok( $list->[2] == 5, 'third item five' ); #------------------------------------------------------------------------ # hash #------------------------------------------------------------------------ my $hash = $config->hash(); ok( $hash, 'got default hash' ); ok( $hash->{ two } == 2, 'item two' ); ok( $hash->{ five } == 5, 'item five' ); #7: read the config from __DATA__ ok( $config->file(\DATA), 'read from file' ); #8 - #9: test foo and baz got reset to defaults correctly ok( $config->foo() == 0, 'foo set to zero' ); ok( $config->baz() eq $BAZDEF, 'baz def stuff' ); #10 - #11: test that "+bar" and "+qux" worked ok( $config->bar() == 1, 'bar is one' ); ok( $config->qux() eq '1', 'qux is one' ); #12 - #15: test that list and hash are set ok( $config->bar() == 1, 'bar still one' ); ok( $config->qux() eq '1', 'qux still one' ); __DATA__ -foo +bar -baz +qux PK��&�[��bm�� compact.tnu��[��#!/usr/bin/perl -w #======================================================================== # # t/compact.t # # AppConfig test file validating the use of the compact definition format. # # Written by Andy Wardley <abw@cre.canon.co.uk> # # Copyright (C) 1998 Canon Research Centre Europe Ltd. # All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use vars qw($loaded); BEGIN { $\| = 1; print "1..19\n"; $" = ', '; } END { ok(0) unless $loaded; } my $ok_count = 1; sub ok { shift or print "not "; print "ok $ok_count\n"; ++$ok_count; } use AppConfig qw(:argcount); $loaded = 1; ok(1); #------------------------------------------------------------------------ # create new AppConfig # my $default = "<default>"; my $anon = "<anon>"; my $user = "Fred Smith"; my $age = 42; my $notarg = "This is not an arg"; my $file1 = 'File_Number_One'; my $file2 = 'File_Number_Two'; my %define = ( 'first' => 'first hash value', 'next' => 'next hash value', 'last' => 'last hash value', ); my $config = AppConfig->new({ ERROR => sub { my $format = "ERR: " . shift() . "\n"; printf STDERR $format, @_; }, GLOBAL => { DEFAULT => $default, ARGCOUNT => ARGCOUNT_ONE, } }, 'verbose\|v!', 'filelist\|file\|f=s@', 'user\|u\|name\|uid=s', 'define\|defvar' => { ARGS => "=s%" }, 'multi' => { ARGCOUNT => ARGCOUNT_LIST, }, 'age\|a' => { VALIDATE => '\d+', # NOTE: Getopt::Long args # constructed automatically }); #2: test the AppConfig got instantiated correctly ok( defined $config ); my @defargs = map { ( "--define", "\"$_=$define{ $_ }\"" ) } keys %define; my @args = ('-v', '-u', $user, '--age', $age, '--file', $file1, '-f', $file2, @defargs, '-multi', 1, '--multi', 2, '-m', 3, $notarg); #3: process the args # $config->_debug(1); ok( $config->getopt(qw(default auto_abbrev), \@args) ); # $config->_debug(0); #4 - #6: check variables got updated ok( $config->verbose() == 1 ); ok( $config->user() eq $user ); ok( $config->age() eq $age ); #7 - #10: check list variable (file) got set my $files; ok( defined ($files = $config->filelist()) ); ok( scalar @$files == 2 ); ok ($files->[0] eq $file1 ); ok ($files->[1] eq $file2 ); #11 - #15: check list variable (multi) got set my $multi; ok( defined ($multi = $config->multi()) ); ok( scalar @$multi == 3 ); foreach my $i (1..3) { ok ($multi->[$i - 1] == $i ); } #16: next arg should be $notarg ok( $args[0] = $notarg ); #17 - #19: check args defaults to using @ARGV @ARGV = ('--age', $age 2, $notarg); ok( $config->getopt() ); ok( $config->age() == ($age * 2) ); ok( $ARGV[0] eq $notarg ); PK��&�[�ء��const.tnu��[��#!/usr/bin/perl -w #======================================================================== # # t/const.t # # AppConfig::Const test file. # # Written by Andy Wardley <abw@cre.canon.co.uk> # # Copyright (C) 1998 Canon Research Centre Europe Ltd. # All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use vars qw($loaded); use Test::More tests => 9; use AppConfig ':expand'; ok(1, 'loaded'); #------------------------------------------------------------------------ #2 - #5: test that the EXPAND_XXX constants got imported # ok( EXPAND_UID, 'EXPAND_UID' ); ok( EXPAND_VAR, 'EXPAND_VAR' ); ok( EXPAND_ENV, 'EXPAND_ENV' ); ok( EXPAND_ALL == EXPAND_UID \| EXPAND_VAR \| EXPAND_ENV, 'EXPAND_ALL' ); #------------------------------------------------------------------------ #6 - #9: test that the EXPAND_XXX package vars are defined # ok( AppConfig::EXPAND_UID, 'EXPAND_UID' ); ok( AppConfig::EXPAND_VAR, 'EXPAND_VAR' ); ok( AppConfig::EXPAND_ENV, 'EXPAND_ENV' ); ok( AppConfig::EXPAND_ALL == AppConfig::EXPAND_UID \| AppConfig::EXPAND_VAR \| AppConfig::EXPAND_ENV, 'EXPAND_ALL' ); PK��&�[BA��sys.tnu��[��#!/usr/bin/perl -w #======================================================================== # # t/sys.t # # AppConfig::Sys test file. # # Written by Andy Wardley <abw@cre.canon.co.uk> # # Copyright (C) 1998 Canon Research Centre Europe Ltd. # All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use vars qw($loaded); use AppConfig::Sys; use Test::More tests => 2; my $DEBUG = grep(/^--?d(ebug)?$/, @ARGV); # create two alternate AppConfig::Sys objects my $sys = AppConfig::Sys->new(); # auto-detect my $winsys = AppConfig::Sys->new('win32'); ok( defined $sys, 'created system object' ); ok( defined $winsys, 'created windows object' ); $sys->_dump if $DEBUG; $winsys->_dump if $DEBUG; if ($DEBUG) { foreach my $s ($sys, $winsys) { print "- " x 36, "\n"; print " os: ", $s->os, "\n"; print " pathsep: ", $s->pathsep, "\n"; print "can_getpwuid: ", $s->can_getpwuid(), "\n"; if($s->can_getpwuid()) { print " getpwuid: ", scalar $s->getpwuid($<), "\n"; print " getpwuid: ", scalar $s->getpwuid(), "\n"; } else { print " getpwuid not available on this platform.\n"; } print "can_getpwnam: ", $s->can_getpwnam(), "\n"; if($s->can_getpwnam()) { print " getpwnam: ", $s->getpwnam('abw'), "\n"; print " getpwnam: ", $s->getpwnam(), "\n"; } else { print " getpwnam not available on this platform.\n"; } } } PK��&�[8�=��99_author.tnu��[��#!/usr/bin/perl -w use strict; BEGIN { $\| = 1; $^W = 1; } use Test::More; # Skip if doing a regular install unless ( $ENV{AUTOMATED_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Can we run the POD tests? eval "use Test::Pod 1.00"; if ( $@ ) { plan( skip_all => "Test::Pod 1.00 required for testing POD" ); } ##################################################################### # WARNING: INSANE BLACK MAGIC ##################################################################### # Hack Pod::Simple::BlackBox to ignore the Test::Inline # "Extended Begin" syntax. # For example, "=begin has more than one word errors" my $begin = \&Pod::Simple::BlackBox::_ponder_begin; sub mybegin { my $para = $_[1]; my $content = join ' ', splice @$para, 2; $content =~ s/^\s+//s; $content =~ s/\s+$//s; my @words = split /\s+/, $content; if ( $words[0] =~ /^test(?:ing)?\z/s ) { foreach ( 2 .. $#$para ) { $para->[$_] = ''; } $para->[2] = $words[0]; } # Continue as normal push @$para, @words; return &$begin(@_); } SCOPE: { local $^W = 0; Pod::Simple::BlackBox::_ponder_begin = \&mybegin; } ##################################################################### # END BLACK MAGIC ##################################################################### # Test POD all_pod_files_ok(); PK��&�[P�#;��block.tnu��[��#!/usr/bin/perl -w #======================================================================== # # t/block.t # # AppConfig::File test file. Tests [block] definitions in config files. # # Written by Andy Wardley <abw@cre.canon.co.uk> # # Copyright (C) 1998 Canon Research Centre Europe Ltd. # All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use vars qw($loaded); use AppConfig qw(:expand :argcount); use AppConfig::File; use Test::More tests => 7; #------------------------------------------------------------------------ # create new AppConfig::State and AppConfig::File objects my $state = AppConfig::State->new( { GLOBAL => { ARGCOUNT => ARGCOUNT_ONE, }, }, 'foo', 'bar', 'dir_home', { EXPAND => EXPAND_ENV, }, 'dir_html', { EXPAND => EXPAND_ENV, }, ); # $state->_debug(1); my $cfgfile = AppConfig::File->new($state); # $state->_debug(0); #2 - #3: test that state and cfgfile got instantiated correctly ok( defined $state, 'defined state' ); ok( defined $cfgfile, 'defined cfgfile' ); #4: read the config file (from __DATA__) ok( $cfgfile->parse(\DATA), 'parsed config' ); #5 - #6: test simple variable values got set correctly ok( $state->foo eq 'This is foo', 'foo is set' ); ok( $state->bar eq 'This is bar', 'bar is set' ); #7 - #8: test [dir] block variables got set correctly SKIP: { skip 'No HOME environment variable set', 2 unless $ENV{ HOME }; ok( $state->dir_home eq $ENV{HOME}, 'matched HOME'); ok( $state->dir_html eq ($ENV{HOME} . '/public_html'), 'matched HTML' ); } #======================================================================== # the rest of the file comprises the sample configuration information # that gets read by parse() # __DATA__ # lines starting with '#' are regarded as comments and are ignored foo = This is foo bar = This is bar [dir] home = ${HOME} html = ${HOME}/public_html PK��&�[$�d��multi.tnu��[��#!/usr/bin/perl -w #======================================================================== # # t/multi.t # # AppConfig::State test file for multiple options (list, hash) # # Written by Andy Wardley <abw@cre.canon.co.uk> # # Copyright (C) 1998 Canon Research Centre Europe Ltd. # All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use vars qw($loaded); BEGIN { $\| = 1; print "1..27\n"; } END { ok(0) unless $loaded; } my $ok_count = 1; sub ok { shift or print "not "; print "ok $ok_count\n"; ++$ok_count; } use AppConfig qw(:argcount); use AppConfig::State; $loaded = 1; ok(1); #------------------------------------------------------------------------ # define variables and handler subs # my $default = "<default>"; my $none = "<none>"; my $user1 = 'foo'; my $user2 = 'bar'; my $user3 = 'baz'; my $var1 = "age=29"; my $var2 = "sex=male"; my $var3 = "eyes=blue"; #------------------------------------------------------------------------ # define a new AppConfig::State object # my $state = AppConfig::State->new({ GLOBAL => { DEFAULT => $default, ARGCOUNT => ARGCOUNT_NONE, }, }, 'verbose', { DEFAULT => 0, }, 'user', { ARGCOUNT => ARGCOUNT_LIST, }, 'var', { ARGCOUNT => ARGCOUNT_HASH, }); #------------------------------------------------------------------------ # check and manipulate variables # #2: check state got defined ok( defined $state ); #3 - #5: check default values ok( $state->verbose() == 0 ); ok( ref($state->user()) eq 'ARRAY' ); ok( ref($state->var()) eq 'HASH' ); #6 - #8: check ARGCOUNT got set explicitly or by default ok( $state->_argcount('verbose') == ARGCOUNT_NONE ); ok( $state->_argcount('user') == ARGCOUNT_LIST ); ok( $state->_argcount('var') == ARGCOUNT_HASH ); #9 - #10: set verbose value and check ok( $state->verbose(1) ); ok( $state->verbose() == 1 ); #11 - #13: set multiple user values ok( $state->user($user1) ); ok( $state->user($user2) ); ok( $state->user($user3) ); #14 - 15: check user values were set my $userlist = $state->user(); ok( ref($userlist) eq 'ARRAY' ); ok( $userlist->[0] eq $user1 && $userlist->[1] eq $user2 && $userlist->[2] eq $user3 ); #16 - #18: set hash var values ok( $state->var($var1) ); ok( $state->var($var2) ); ok( $state->var($var3) ); #19 - #22: check var hash value were set my $varhash = $state->var(); ok( ref($varhash) eq 'HASH' ); ok( $varhash->{'age'} == 29 ); ok( $varhash->{'sex'} eq 'male' ); ok( $varhash->{'eyes'} eq 'blue' ); #23 - #25 : reset values to defaults ok( $state->_default('verbose') eq 0 ); ok( ref($state->_default('user')) eq 'ARRAY' ); ok( ref($state->_default('var')) eq 'HASH' ); #26 - #27: check default ARRAY/HASH are empty ok( scalar @{ $state->user() } == 0 ); ok( scalar %{ $state->var() } == 0 ); PK��&�[p�M;D ��D ��args.tnu��[��#!/usr/bin/perl -w #======================================================================== # # t/args.t # # AppConfig::Args test file. # # Written by Andy Wardley <abw@cre.canon.co.uk> # # Copyright (C) 1998 Canon Research Centre Europe Ltd. # All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #------------------------------------------------------------------------ # TODO # * test PEDANTIC option # #======================================================================== use lib qw( ../lib ./lib ); use strict; use vars qw($loaded); use AppConfig qw(:argcount); use AppConfig::Args; use Test::More tests => 17; ok(1, 'loaded'); #------------------------------------------------------------------------ # create new AppConfig::State and AppConfig::Args objects #------------------------------------------------------------------------ my $default = "<default>"; my $anon = "<anon>"; my $user = "Fred Smith"; my $age = 42; my $notarg = "This is not an arg"; my $state = AppConfig::State->new({ GLOBAL => { DEFAULT => $default, ARGCOUNT => ARGCOUNT_ONE, } }, 'verbose' => { DEFAULT => 0, ARGCOUNT => ARGCOUNT_NONE, ALIAS => 'v', }, 'user' => { ALIAS => 'u\|name\|uid', DEFAULT => $anon, }, 'age' => { ALIAS => 'a', VALIDATE => '\d+', }); my $cfgargs = AppConfig::Args->new($state); ok( defined $state, 'defined state' ); ok( defined $cfgargs, 'defined cfgargs' ); my @args = ('-v', '-u', $user, '-age', $age, $notarg); ok( $cfgargs->parse(\@args), 'parse' ); is( $state->verbose(), 1, 'verbose' ); is( $state->user(), $user, 'user' ); is( $state->age(), $age, 'age' ); is( $args[0], $notarg, 'next arg' ); @ARGV = ('--age', $age * 2, $notarg); ok( $cfgargs->parse(), 'second parse' ); is( $state->age(), $age * 2, 'second age' ); is( $ARGV[0], $notarg, 'second next arg' ); @ARGV = ('--user=Andy_Wardley', '--age=30'); ok( $cfgargs->parse(), 'third parse' ); is( $state->age(), 30, 'third age' ); is( $state->user(), 'Andy_Wardley', 'third user' ); @ARGV = ('--user', 'Me Again', '--age', '34'); ok( $cfgargs->parse(), 'fourth parse' ); is( $state->age(), 34, 'fourth age' ); is( $state->user(), 'Me Again', 'fourth user' ); PK��&�[��ņ��flag.tnu��[��#!/usr/bin/perl -w #======================================================================== # # t/flag.t # # Tests the setting and unsetting of flag variables. # # Written by Andy Wardley <abw@cre.canon.co.uk> # # Copyright (C) 1998 Canon Research Centre Europe Ltd. # All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #------------------------------------------------------------------------ # # TODO # # * test PEDANTIC option # # * test EXPAND_WARN option # #======================================================================== use strict; use vars qw($loaded @expect); BEGIN { # what we expect the debug state(s) to be @expect = qw(1 0 1 0 1 0 1 0 1 0 1 0 1 1 1 0); my $max = 3 + @expect; $\| = 1; print "1..$max\n"; } END { ok(0) unless $loaded; } my $ok_count = 1; sub ok { shift or print "not "; print "ok $ok_count\n"; ++$ok_count; } use AppConfig qw(:expand :argcount); $loaded = 1; ok(1); #------------------------------------------------------------------------ # define storage and callback for keeping track of the state of 'debug' # variable as it changes. # my @debug; # callback routine to store the state of 'debug' each time it changes sub debug_set { my $cfg = shift; my $var = shift; my $val = shift; push(@debug, $val); 1; } #------------------------------------------------------------------------ # create new AppConfig object # my $config = AppConfig->new('debug', { ACTION => \&debug_set }); #2: test config got instantiated correctly ok( defined $config ); #3: read the config file (from __DATA__) ok( $config->file(\DATA) ); while (@expect) { my $e = shift @expect; my $d = shift @debug; ok( $e == $d ); } #======================================================================== # the rest of the file comprises the sample configuration information # that gets read by file() # __DATA__ debug debug 0 debug 1 debug = 0 debug = 1 debug off debug on debug Off debug On debug OFF debug ON debug = off debug = on debug is very much turned on debug = a turned on thing nodebug PK��&�[��6ƛ��getopt.tnu��[��#!/usr/bin/perl -w #======================================================================== # # t/getopt.t # # AppConfig::Getopt test file. # # Written by Andy Wardley <abw@cre.canon.co.uk> # # Copyright (C) 1998 Canon Research Centre Europe Ltd. # All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use vars qw($loaded); BEGIN { $\| = 1; print "1..10\n"; } END { ok(0) unless $loaded; } my $ok_count = 1; sub ok { shift or print "not "; print "ok $ok_count\n"; ++$ok_count; } use AppConfig qw(:argcount); $loaded = 1; ok(1); #------------------------------------------------------------------------ # create new AppConfig # my $default = "<default>"; my $anon = "<anon>"; my $user = "Fred Smith"; my $age = 42; my $notarg = "This is not an arg"; my $config = AppConfig->new({ # DEBUG => 1, ERROR => sub { my $format = "ERR: " . shift() . "\n"; printf STDERR $format, @_; }, GLOBAL => { DEFAULT => $default, ARGCOUNT => ARGCOUNT_ONE, } }, 'verbose' => { DEFAULT => 0, ARGCOUNT => ARGCOUNT_NONE, ALIAS => 'v', }, 'user' => { ALIAS => 'u\|name\|uid', ARGS => '=s', # explicit Getopt::Long args DEFAULT => $anon, }, 'age' => { ALIAS => 'a', VALIDATE => '\d+', # NOTE: Getopt::Long args # constructed automatically }); #2: test the AppConfig got instantiated correctly ok( defined $config ); my @args = ('-v', '-u', $user, '--age', $age, $notarg); #3: process the args # $config->_debug(1); ok( $config->getopt(qw(default auto_abbrev), \@args) ); # $config->_debug(0); #4 - #6: check variables got updated ok( $config->verbose() == 1 ); ok( $config->user() eq $user ); ok( $config->age() eq $age ); #7: next arg should be $notarg ok( $args[0] = $notarg ); #8 - #10: check args defaults to using @ARGV @ARGV = ('--age', $age 2, $notarg); ok( $config->getopt() ); ok( $config->age() == ($age * 2) ); ok( $ARGV[0] eq $notarg ); PK��&�[��+��state.tnu��[��#!/usr/bin/perl -w #======================================================================== # # t/state.t # # AppConfig::State test file. # # Written by Andy Wardley <abw@cre.canon.co.uk> # # Copyright (C) 1998 Canon Research Centre Europe Ltd. # All Rights Reserved. # # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # #======================================================================== use strict; use vars qw($loaded); BEGIN { $\| = 1; print "1..45\n"; } END { ok(0) unless $loaded; } my $ok_count = 1; sub ok { shift or print "not "; print "ok $ok_count\n"; ++$ok_count; } use AppConfig qw(:argcount); use AppConfig::State; $loaded = 1; ok(1); #------------------------------------------------------------------------ # define variables and handler subs # my $default = "<default>"; my $none = "<none>"; my $user = 'abw'; my $age = 29; my $verbose = 0; my $errors = 0; # user validation routine sub check_user { my $var = shift; my $val = shift; return ($val eq $user); } # verbose action routine sub verbose { my $state = shift; my $var = shift; my $val = shift; # set global $verbose so we can test that this sub was called $verbose = $val; # ok return 1; } sub error { my $format = shift; my @args = @_; $errors++; } #------------------------------------------------------------------------ # define a new AppConfig::State object # my $state = AppConfig::State->new({ ERROR => \&error, GLOBAL => { DEFAULT => $default, ARGCOUNT => ARGCOUNT_ONE, }, }, 'verbose', { DEFAULT => 0, ACTION => \&verbose, ARGCOUNT => ARGCOUNT_NONE, }, 'user', { ALIAS => 'name\|uid', VALIDATE => \&check_user, DEFAULT => $none, }, 'age', { VALIDATE => '\d+', }); # $state->_dump(); #------------------------------------------------------------------------ # check and manipulate variables # #2: check state got defined ok( defined $state ); #3 - #5: check default values ok( $state->verbose() == 0 ); ok( $state->user() eq $none ); ok( $state->age() eq $default ); #6 - #8: check ARGCOUNT got set explicitly or by default ok( $state->_argcount('verbose') == 0 ); ok( $state->_argcount('user') == 1 ); ok( $state->_argcount('age') == 1 ); #9 - #11: set values ok( $state->verbose(1) ); ok( $state->user($user) ); ok( $state->age($age) ); #12 - #14: read them back to check values got set correctly ok( $state->verbose() == 1 ); ok( $state->user() eq $user ); ok( $state->age() == $age ); #15: test that the verbose ACTION was called and $verbose set ok( $verbose == 1 ); #16 - #19: test the VALIDATE patterns/subs by attempting to set invalid values ok( ! $state->age('old') ); ok( $state->age() == $age ); ok( ! $state->user('dud') ); ok( $state->user() eq $user ); #20: check that the error handler correctly updated $errors ok( $errors == 2 ); #21 - #22: access variables via alias ok( $state->name() eq $user ); ok( $state->uid() eq $user ); #23 - #25: test case insensitivity ok( $state->USER() eq $user ); ok( $state->NAME() eq $user ); ok( $state->UID() eq $user ); #26 - #27: explicitly test get() and set() methods ok( $state->set('verbose', 100) ); ok( $state->get('verbose') == 100 ); #------------------------------------------------------------------------ # define a different AppConfig::State object # my $newstate = AppConfig::State->new({ CASE => 1, CREATE => '^define_', PEDANTIC => 1, ERROR => \&error, }); #28: check state got defined ok( defined $newstate ); #29 - #30: test CASE sensitivity $errors = 0; ok( ! $newstate->Foo() ); ok( $errors ); #31 - #32: test PEDANTIC mode is/isn't set in states ok( ! $state->_pedantic() ); ok( $newstate->_pedantic() ); #33 - #34: test auto-creation of define_ variable ok( $newstate->define_user($user) ); ok( $newstate->define_user() eq $user ); #------------------------------------------------------------------------ # define a third AppConfig::State object to test compact format # my $thirdstate = AppConfig::State->new("foo\|bar\|baz=s"); #35: check state got defined ok( defined $thirdstate ); $thirdstate->define("tom\|dick\|harry=i@"); $thirdstate->define("red\|green\|blue=s"); #36 - #42: check set()/get() for foo and aliases ok( $thirdstate->foo(5) ); ok( $thirdstate->foo() == 5 ); ok( $thirdstate->bar(6) ); ok( $thirdstate->bar() == 6 ); ok( $thirdstate->baz(7) ); ok( $thirdstate->baz() == 7 ); ok( $thirdstate->foo() == 7 ); #43 - #45: check ARGCOUNT for all vars ok( $thirdstate->_args('foo') eq '=s' ); ok( $thirdstate->_args('tom') eq '=i@' ); ok( $thirdstate->_args('red') eq '=s' ); PK��&�[܏�I!��!��97-pod.tnu��[��#!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; # Skip if doing a regular install unless ( $ENV{AUTOMATED_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } all_pod_files_ok(); PK��V�[�[-�� roytest3.htmlnu��[��PK��V�[�NF7- ��- ��L��query.tnu��[��PK��V�[�� iri.tnu��[��PK��V�["3F��$��num_eq.tnu��[��PK��V�[�y<!��!��t&��utf8.tnu��[��PK��V�[R_�h��h��,��geo_construct.tnu��[��PK��V�[5��mn��n�� r5��rfc2732.tnu��[��PK��V�[�y��=��geo_basic.tnu��[��PK��V�[�ola��:D��mix.tnu��[��PK��V�[�-F �� /J��sq-brackets.tnu��[��PK��V�[�FT��yj��geo_point.tnu��[��PK��V�[�\n�" ��" �� al��roytest5.htmlnu��[��PK��V�[%��y��abs.tnu��[��PK��V�[$e��e�� escape-char.tnu��[��PK��V�[_k�n�� [��userpass.tnu��[��PK��V�[��\ ��\ ��B��mailto.tnu��[��PK��V�[>�� ֝��roytest4.htmlnu��[��PK��V�[8y��rtsp.tnu��[��PK��V�[!A��\��news.tnu��[��PK��V�[�!�G�� query-param.tnu��[��PK��V�[�;�'��ipv6.tnu��[��PK��V�["�L�� Ǽ��storable.tnu��[��PK��V�[��5� �� ldap.tnu��[��PK��V�[��Q��Q��icap.tnu��[��PK��V�[u,�� /��old-file.tnu��[��PK��V�[��$��$�� D��old-base.tnu��[��PK��V�[�2<�E��E�� _�roytest1.htmlnu��[��PK��V�[ �� $}�path-segments.tnu��[��PK��V�[��K��ftp.tnu��[��PK��V�[��]�0��0��w��00-report-prereqs.ddnu��[��PK��V�[]:y��escape.tnu��[��PK��V�[@b�����00-report-prereqs.tnu��[��PK��V�[��idna.tnu��[��PK��V�[�� G��urn-isbn.tnu��[��PK��V�[̒�' �� k��urn-scheme-exceptions.tnu��[��PK��V�[�m��gopher.tnu��[��PK��V�[d��2��scheme-exceptions.tnu��[��PK��V�[�I�K��K��clone.tnu��[��PK��V�[�fB��rel.tnu��[��PK��V�[ x�l��rsync.tnu��[��PK��V�[�!��(��sip.tnu��[��PK��V�[�{BM<��<��H��pop.tnu��[��PK��V�[�L�-U��U��sq-brackets-legacy.tnu��[��PK��V�[ʇ��R��heuristic.tnu��[��PK��V�[� �V+��+��d��mms.tnu��[��PK��V�[Ǧ�� old-absconf.tnu��[��PK��V�[�Cp(A��A��storable-test.plnu��[��PK��V�[.��\��split.tnu��[��PK��V�[�W�-!��-!�� u��otpauth.tnu��[��PK��V�[(�}# �� data.tnu��[��PK��V�[��`S��S��-�http.tnu��[��PK��V�[�;�� roy-test.tnu��[��PK��V�[s\�<��<�� roytest2.htmlnu��[��PK��V�[�� ,�generic.tnu��[��PK��V�[�36�� ;�urn-oid.tnu��[��PK��V�[U��$ ��$ ��l<�file.tnu��[��PK��V�[��nn�� \�punycode.tnu��[��PK��V�[KN�b��b��e�sort-hash-query-form.tnu��[��PK��V�[Ȇ�ð��g�cwd.tnu��[��PK��V�[Y�� ph�old-relbase.tnu��[��PK��[���k�chmod.tnu��[��PK��[j�� o�symlinks.tnu��[��PK��[+U�Б�� v�recurse.tnu��[��PK��[P��K@��@��ޅ�parent.tnu��[��PK��[9��Y�� V��rel-abs.tnu��[��PK��[,n& ��data/chmod.txtnu��[��PK��[XIF�p��p�� w�basename.tnu��[��PK��[�X��8��8��z�fakelib/PerlIO/utf8_strict.pmnu��[��PK��[�#�2��2��2{�fakelib/Unicode/UTF8.pmnu��[��PK��[̠p��{�mutable_tree_while_iterating.tnu��[��PK��[�� U�� exports.tnu��[��PK��[�� subsumes.tnu��[��PK��[�.B��l��mkdir.tnu��[��PK��[��u�f��f��basic.tnu��[��PK��[��A��0��digest.tnu��[��PK��[�Fu�~��~�� l��locking.tnu��[��PK��[.=�BI��BI��#��input_output.tnu��[��PK��[,x�� sig_die.tnu��[��PK��[�G�e6��6��input_output_no_UU.tnu��[��PK��[�q�� k��children.tnu��[��PK��[�� size.tnu��[��PK��[O�а\|��\|�� zzz-spec.tnu��[��PK��[~�C�� '�overloading.tnu��[��PK��[�?�ׂ��)�normalize.tnu��[��PK��[}��C��C��-�input_output_no_PU_UU.tnu��[��PK��[W/gW��20�visit.tnu��[��PK��[��-��(2�mkpath.tnu��[��PK��[M�~Z��6�exception.tnu��[��PK��[0;��Z;�zz-atomic.tnu��[��PK��[kC��/?�temp.tnu��[��PK��[&.\[F7��F7��XS�filesystem.tnu��[��PK��[��{N��N��ڊ�lib/TestUtils.pmnu��[��PK��[k��h��READMEnu��[��PK��[%�Y�.��.��t��has_same_bytes.tnu��[��PK��[�ϔv��01-base32hex.tnu��[��PK��[�騌��00-base32.tnu��[��PK��[�� ͨ�Exporter.tnu��[��PK��[a�I�+��+��warn.tnu��[��PK��[^��use.tnu��[��PK��[ْ@k��pod.tnu��[��PK��[[+�.�� 35limit.tnu��[��PK��[��N�? ��? ��35prepare.tnu��[��PK��[%�D�� A��81procs.tnu��[��PK��[qi�Q��$��P��rt61849-bind-param-buffer-overflow.tnu��[��PK��[O0�f��k��40server_prepare_error.tnu��[��PK��[,�N��N��{��71impdata.tnu��[��PK��[��)#r��r��gh352.tnu��[��PK��[��51bind_type_guessing.tnu��[��PK��[a��92ssl_optional.tnu��[��PK��[�.~��~��65segfault.tnu��[��PK��[�3c��rt83494-quotes-comments.tnu��[��PK��[�� u�17quote.tnu��[��PK��[��i\|� �� !�rt75353-innodb-lock-timeout.tnu��[��PK��[��faP��P��,�53comment.tnu��[��PK��[��{4�52comment.tnu��[��PK��[`;��<�rt88006-bit-prepare.tnu��[��PK��[D�=z��mK�lib.plnu��[��PK��[0�i)��6[�32insert_error.tnu��[��PK��[�Hϥ��^�01caching_sha2_prime.tnu��[��PK��[W C>�� b�40bit.tnu��[��PK��[A:��Zg�92ssl_backronym_vulnerability.tnu��[��PK��[�҅#� �� m�80procs.tnu��[��PK��[\l_j��j��x�76multi_statement.tnu��[��PK��[�ܽѿ �� ^��40types.tnu��[��PK��[[��< ��< ��V��40server_prepare.tnu��[��PK��[�׹�� ԟ�57trackgtid.tnu��[��PK��[\�#j��55utf8.tnu��[��PK��[�.{Ǒ �� 70takeimp.tnu��[��PK��[�5"��!��99_bug_server_prepare_blob_null.tnu��[��PK��[�A�c��[��29warnings.tnu��[��PK��[$�t�� 41bindparam.tnu��[��PK��[�E:��rt110983-valid-mysqlfd.tnu��[��PK��[�O�o�� 42bindparam.tnu��[��PK��[B�0�R��R�� rt91715.tnu��[��PK��[d��-��-��41blobs_prepare.tnu��[��PK��[�~�zz��z��00base.tnu��[��PK��[ ��X��X�� 87async.tnu��[��PK��[�;{��S��92ssl_riddle_vulnerability.tnu��[��PK��[9�n<��<�� 65types.tnu��[��PK��[Ÿ�^�� 40nulls.tnu��[��PK��[�F�,��' �40keyinfo.tnu��[��PK��[�>w�"��"�� T�manifest.tnu��[��PK��[�-��75supported_sql.tnu��[��PK��[�pn��rt25389-bin-case.tnu��[��PK��[ùۖ�� version.tnu��[��PK��[��>qA��A��40bindparam2.tnu��[��PK��[�� !%�60leaks.tnu��[��PK��[�c �� D�40bindparam.tnu��[��PK��[��+��O�85init_command.tnu��[��PK��[�P-~��S�86_bug_36972.tnu��[��PK��[�s)��:X�rt86153-reconnect-fail-memory.tnu��[��PK��[ �?��L`�16dbi-get_info.tnu��[��PK��[Ӓ�>��e�mysql.mtestnu��[��PK��[#�p�?��?��i�41int_min_max.tnu��[��PK��[%�"��40server_prepare_crash.tnu��[��PK��[�Ӆۆ�� ��40blobs.tnu��[��PK��[^��J��J��gh360.tnu��[��PK��[�k�w/��/�� j��15reconnect.tnu��[��PK��[��Ɗ'��'��!��֝�rt50304-column_info_parentheses.tnu��[��PK��[vẇd ��d ��N��10connect.tnu��[��PK��[��f~ ��~ �� 50commit.tnu��[��PK��[�`ݙ��30insertfetch.tnu��[��PK��[%XR��rt118977-zerofill.tnu��[��PK��[�3�&��n��91errcheck.tnu��[��PK��[iFH�I ��I ��rt85919-fetch-lost-connection.tnu��[��PK��[��~��'��56connattr.tnu��[��PK��[�H�7 ��7 ��31insertid.tnu��[��PK��[Nᨣ� �� l��40nulls_prepare.tnu��[��PK��[��-��-��55utf8mb4.tnu��[��PK��[ ��)��)��40catalog.tnu��[��PK��[j��N�89async-method-check.tnu��[��PK��[d�Z��m,�40numrows.tnu��[��PK��[!��4�05dbcreate.tnu��[��PK��[��&�9��9��7�50chopblanks.tnu��[��PK��[(��/C�88async-multi-stmts.tnu��[��PK��[�"L��G�20createdrop.tnu��[��PK��[e�%o/��/��>J�99compression.tnu��[��PK��[�F&��N�25lockunlock.tnu��[��PK��[��[��T�43count_params.tnu��[��PK��[�1�1��\�40listfields.tnu��[��PK��[��\��e�render_xml.tnu��[��PK��[X�� +i�render.yamlnu��[��PK��[�!<S��si�render.jsonnu��[��PK��[�D�'.��.��i�release-pod-syntax.tnu��[��PK��[ϵ��8k�000-compile-modules.tnu��[��PK��[�@�s��ol�template/signature.ttnu��[��PK��[5��%=��=��l�template/letter.ttnu��[��PK��[]-<�� Dm�render_json.tnu��[��PK��[p�[�� {p�render_yaml.tnu��[��PK��[V�#��#�� Ms�render.xmlnu��[��PK��[a�sB �� s�cli.tnu��[��PK��[�y0�� w�examples.tnu��[��PK��[�94�(W��(W�� ~�zzz-lwp.tnu��[��PK��[c�:�� y��cookies_for.tnu��[��PK��[�E�$��publicsuffix.tnu��[��PK��[�>�� !��parse.tnu��[��PK��[j`��sort.tnu��[��PK��[W�Jiy��y��save.tnu��[��PK��[8�Dr"��r"��add.tnu��[��PK��[K��I;��;��V#�lib/MockTime.pmnu��[��PK��[�:�Oe��e�� $�07_eval.tnu��[��PK��[e��N��N��n'�10_bad_use.tnu��[��PK��[�jv�J��J��)�06_threads.tnu��[��PK��[�� ~,�04_test_funcs.tnu��[��PK��[�8�p��.�13_do.tnu�ȯ��PK��[S��/�05_script.tnu��[��PK��[!̧�� 0�12_padstale.tnu��[��PK��[�I�� 1�02_refs.tnu��[��PK��[y�� !4�03_count.tnu��[��PK��[�+��s��s��$6�00_compile.tnu��Iw��PK��[�Ʃ�� 6�01_info.tnu��[��PK��[]�F'&��&��:�08_leaktrace.tnu��[��PK��[i��6�� =�lib/foo.plnu�ȯ��PK��[��#��#�� V=�11_logfp.tnu��[��PK��[��^��A�09_info_more.tnu��[��PK��[F�$��E�like-exception.tnu��[��PK��[��ײ��H�todo.tnu�ȯ��PK��[J�6 �� U�find_missing.tnu��[��PK��[�Y輿�� ]�numify_version.tnu��[��PK��[Mv�Z��Z��d�standalone.tnu��[��PK��[�1�e��e��d�test2.tnu��[��PK��[[��p��p��>e�test-builder.tnu��[��PK��[}�j �� e�lib/TestAPI.pmnu��[��PK��[��2��2��7�lib/ModuleWithVersion.pmnu��[��PK��[�bBG��lib/BrokenModule.pmnu��[��PK��[�5�9��9��lib/TestScript.pmnu��[��PK��[�Z��q��found.tnu��[��PK��[�GV��h��not_found.tnu��[��PK��[D��W��I��flags.tnu��[��PK��[�\|�<��<��4��bad-single-word-compiler.tnu��[��PK��[ �}l�� dash-l-libs.tnu��[��PK��[�Qg`��`�� headers.tnu��[��PK��[��Տ �� Z��custom-function.tnu��[��PK��[��&��&����inc/headerfile.hnu��[��PK��[t�;��;��cmdline-LIBS-INC.tnu��[��PK��[2b�� multi-word-compiler.tnu��[��PK��[�R�Z&��&��m��exit_with_message.tnu��[��PK��[sr�\6��6��analyze-binary.tnu��[��PK��[$��݈��L��coverage.shnu�ȯ��PK��[~�Y_�� 00-load.tnu��[��PK��[k�� 0��lib/Helper.pmnu��[��PK��[�b��9��v4-split-list.tnu��[��PK��[`U�C��!��full.tnu��[��PK��[�v\|�� (��v4-compplus.tnu��[��PK��[�'R(:��:��x��v4-re.tnu��[��PK��[�I�Y��Y�� masklen.tnu��[��PK��[�h\+��{��full6.tnu��[��PK��[��,��,��new-store.tnu��[��PK��["��v6-split-bulk.tnu��[��PK��[�{\|����v4-compact.tnu��[��PK��[X��constants.tnu��[��PK��[yz�]��?��short.tnu��[��PK��[>��C"��"�� > �wildcard.tnu��[��PK��[��r�s��s�� rfc3021.tnu��[��PK��[3��F �v6-re.tnu��[��PK��[��b��, �canon.tnu��[��PK��[<%�� C �v4-coalesce.tnu��[��PK��[�eAyi��i��] �imhoff.tnu��[��PK��[�� v4-sprefix.tnu��[��PK��[�i�<��E �loops.tnu��[��PK��[Q�#�� v4-hostenum.tnu��[��PK��[]s�� P# �splitref.tnu��[��PK��[��ǂ��w& �lower.tnu��[��PK��[�6��' �v4-splitplan.tnu��[��PK��[�+�� 0 �over-arr.tnu��[��PK��[2 � �� 2 �over-qq.tnu��[��PK��[e��=6 �relops.tnu��[��PK��[Y��&e ��e ��< �v6-splitplan.tnu��[��PK��[�� 6F �nofqdn.tnu��[��PK��[��I��I��#H �old-store.tnu��[��PK��[Ƅd��K �v4-xprefix.tnu��[��PK��[�s�#��#��N �v4-split-bulk.tnu��[��PK��[h�Q��JQ �full6-uri.tnu��[��PK��[��~��~��\T �regexp.tnu��[��PK��[�1[��` �boolean-jsonpp.tnu��[��PK��[�9��Oc �duplicate-keys.tnu��[��PK��[�B�`\��\��e �native.tnu��[��PK��[p�hk��g �000-require-modules.tnu��[��PK��[��wȯ�� uh �boolean.tnu��[��PK��[�̑� �� ]m �blessed.tnu��[��PK��[�El~��p �empty.tnu��[��PK��[h��s �glob.tnu��[��PK��["�2�� v �pl_sv_undef.tnu��[��PK��[��٣��Qx �data/basic.ymlnu��[��PK��[-��q��\|\| �magic.tnu��[��PK��[�j�m��m��} �io-handle.tnu��[��PK��[`_Wo �� s� �dump-heuristics.tnu��[��PK��[�� string_nulls.tnu��[��PK��[�o�� boolean-invalid.tnu��[��PK��[��N��N�� indent.tnu��[��PK��[�� empty.yamlnu��[��PK��[v��7�� quote.tnu��[��PK��[��?��?��1� �null.tnu��[��PK��[�� loadfile-empty.tnu��[��PK��[B�x� �� path-class.tnu��[��PK��[�kbZ�� bug-stack.tnu��[��PK��[/�� � �boolean-boolean.tnu��[��PK��[��{��{��x� �binary.tnu��[��PK��[U��+� �libyaml-version.tnu��[��PK��[�r�e��e��d� �ascii.tnu��[��PK��[ (�� leak.tnu��[��PK��[�L��,��,��9� �author-pod-syntax.tnu��[��PK��[̟T�� load.tnu��[��PK��[0�>��Ħ �dump.tnu��[��PK��[W_;l��ݧ �TestYAML.pmnu��[��PK��[Oy�� private.tnu��[��PK��[�^�[����Ī �tags.tnu��[��PK��[�ܙ�� $� �bug-pvf.tnu��[��PK��[�N^�� D� �TestYAMLTests.pmnu��[��PK��[Z�)&��k� �alias.tnu��[��PK��[��?W�� code.tnu��[��PK��[�p&�L��L�� numbers.tnu��[��PK��[%J�� 6� �dump-int.tnu��[��PK��[xa�˥��!� �long_plain_wrap.tnu��[��PK��[�3�7��7�� yaml_tests.yamlnu��[��PK��[�R>��}� �api.tnu��[��PK��[k�U �� ref-scalar.tnu��[��PK��[�(�K��K�� load_standard_tags.tnu��[��PK��[=� �C��C��M� �error.tnu��[��PK��[��p�� load-blessed.tnu��[��PK��[� I�� tied.tnu��[��PK��[zI�"�� 03.github-issue-5.tnu��[��PK��[J��£:��:�� 01.legacy.tnu��[��PK��[&�L~+��+��u/ �02.legacy-symtogsafe.tnu��[��PK��[k%�E��E�� A �00.load.tnu��[��PK��[��dB �04.readonly-dir.tnu��[��PK��[d~r�^ ��^ ��wF �05.legacy-pathmk_unc.tnu��[��PK��[��P �Data-Validate-IP.tnu��[��PK��[��o��P �Data-Validate-IP-slow.tnu��[��PK��[��V%(��%(��R �lib/Test/Data/Validate/IP.pmnu��[��PK��[�M�� yz �Untaint.tnu��[��PK��[�B!.'��'��E� �none.tnu��[��PK��[t �� set.tnu��[��PK��[%S�� bag.tnu��[��PK��[ �� memory.tnu��[��PK��[��e�� x� �shallow.tnu��[��PK��[/�i��ʶ �array.tnu��[��PK��[��H1��1�� leaf-wrapper.tnu��[��PK��[v�� 0��0�� class.tnu��[��PK��[�8C�� cache.tnu��[��PK��[>�Q�� reftype.tnu��[��PK��[�×�� listmethods.tnu��[��PK��[�shC��C�� hash_each.tnu��[��PK��[iX>��>��~� �string.tnu��[��PK��[d��}��}�� isa.tnu��[��PK��[7ݮc�� no-clobber-globals.tnu��[��PK��[�H�� bagrecursion.tnu��[��PK��[}[�B�� 6� �regexp.t.orignu��[��PK��[Qʐ�F��F�� hashkeys.tnu��[��PK��[��{ �� array_each.tnu��[��PK��[۽;.��R� �number.tnu��[��PK��[�*j��j�� j� �descend.tnu��[��PK��[ xy@�� circular.tnu��[��PK��[��i�t��t��X�import.tnu��[��PK��[�:5��all.tnu��[��PK��[yx�� regexpref.tnu��[��PK��[��D�hash.tnu��[��PK��[@Ֆ�[��[��G�notest_withtest.tnu��[��PK��[ �ӳ��scalarref.tnu��[��PK��[�s��scalar.tnu��[��PK��[�p�[��[�� arraylength.tnu��[��PK��[u�ϣ��=#�notest_extra.tnu��[��PK��[��W$�notest.tnu��[��PK��[Ʃb�� W%�lib/Std.pmnu��[��PK��[o��]&�lib/Over.pmnu��[��PK��[�\|��-��-��'�deep_utils.tnu��[��PK��['j/6��6��)�rt78288_blessed_object.tnu��[��PK��[lgo�� i+�methods.tnu��[��PK��[�g��\5�ignore.tnu��[��PK��[��Ϧ��p6�any.tnu��[��PK��[��2��K:�05_success.tnu��Iw��PK��[��L;�02_no_plan.tnu��Iw��PK��[�D��H<�03_import_hashref.tnu��Iw��PK��[�ˀ��v=�04_import_array.tnu��Iw��PK��[��v>�01_simple.tnu��Iw��PK��[�yY��s?�06_perlver.tnu��Iw��PK��&�[ �^��^��@�appconfig.tnu��[��PK��&�[�,)��OH�novars.tnu��[��PK��&�[>�ӄ��>Q�cgi.tnu��[��PK��&�[R]�� 4Y�default.tnu��[��PK��&�[��bm�� :d�compact.tnu��[��PK��&�[�ء��p�const.tnu��[��PK��&�[BA��u�sys.tnu��[��PK��&�[8�=��\|�99_author.tnu��[��PK��&�[P�#;��block.tnu��[��PK��&�[$�d��multi.tnu��[��PK��&�[p�M;D ��D ��args.tnu��[��PK��&�[��ņ�� flag.tnu��[��PK��&�[��6ƛ��ܩ�getopt.tnu��[��PK��&�[��+��state.tnu��[��PK��&�[܏�I!��!��97-pod.tnu��[��PK�� t��

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