Mr.X

#!./perl -w
#
#  Copyright 2002, Larry Wall.
#
#  You may redistribute only under the same terms as Perl 5, as specified
#  in the README file that comes with the distribution.
#

# I ought to keep this test easily backwards compatible to 5.004, so no
# qr//;

# This test checks whether the kludge to interwork with 5.6 Storables compiled
# on Unix systems with IV as long long works.

sub BEGIN {
    unshift @INC, 't';
    unshift @INC, 't/compat' if $] < 5.006002;
    require Config; import Config;
    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
        print "1..0 # Skip: Storable was not built\n";
        exit 0;
    }
    unless ($Config{ivsize} and $Config{ivsize} > $Config{longsize}) {
        print "1..0 # Skip: Your IVs are no larger than your longs\n";
        exit 0;
    }
}

use Storable qw(freeze thaw);
use strict;
use Test::More tests=>30;

our (%tests);

{
    local $/ = "\n\nend\n";
    while (<DATA>) {
        next unless /\S/s;
        unless (/begin ([0-7]{3}) ([^\n]*)\n(.*)$/s) {
            s/\n.*//s;
            warn "Dodgy data in section starting '$_'";
            next;
        }
        next unless oct $1 == ord 'A'; # Skip ASCII on EBCDIC, and vice versa
        my $data = unpack 'u', $3;
        $tests{$2} = $data;
    }
}

# perl makes easy things easy, and hard things possible:
my $test = freeze \'Hell';

my $header = Storable::read_magic ($test);

is ($header->{byteorder}, $Config{byteorder},
    "header's byteorder and Config.pm's should agree");

my $result = eval {thaw $test};
isa_ok ($result, 'SCALAR', "Check thawing test data");
is ($@, '', "causes no errors");
is ($$result, 'Hell', 'and gives the expected data');

my $kingdom = $Config{byteorder} =~ /23/ ? "Lillput" : "Belfuscu";

my $name = join ',', $kingdom, @$header{qw(intsize longsize ptrsize nvsize)};

SKIP: {
    my $real_thing = $tests{$name};
    if (!defined $real_thing) {
        print << "EOM";
# No test data for Storable 1.x for:
#
# byteorder	 '$Config{byteorder}'
# sizeof(int)	 $$header{intsize}
# sizeof(long)	 $$header{longsize}
# sizeof(char *) $$header{ptrsize}
# sizeof(NV)	 $$header{nvsize}

# If you have Storable 1.x built with perl 5.6.x on this platform, please
# make_56_interwork.pl to generate test data, and append the test data to
# this test. 
# You may find that make_56_interwork.pl reports that your platform has no
# interworking problems, in which case you need do nothing.
EOM
        skip "# No 1.x test file", 9;
    }
    my $result = eval {thaw $real_thing};
    is ($result, undef, "By default should not be able to thaw");
    like ($@, qr/Byte order is not compatible/,
          "because the header byte order strings differ");
    local $Storable::interwork_56_64bit = 1;
    $result = eval {thaw $real_thing};
    isa_ok ($result, 'ARRAY', "With flag should now thaw");
    is ($@, '', "with no errors");

    # However, as the file is written with Storable pre 2.01, it's a known
    # bug that large (positive) UVs become IVs
    my $value = (~0 ^ (~0 >> 1) ^ 2);

    is (@$result, 4, "4 elements in array");
    like ($$result[0],
          qr/^This file was written with [0-9.]+ on perl [0-9.]+\z/,
         "1st element");
    is ($$result[1], "$kingdom was correct", "2nd element");
    cmp_ok ($$result[2] ^ $value, '==', 0, "3rd element") or
        printf "# expected %#X, got %#X\n", $value, $$result[2];
    is ($$result[3], "The End", "4th element");
}

$result = eval {thaw $test};
isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
is ($@, '', "        causes no errors");
is ($$result, 'Hell', "        and gives the expected data");

my $test_kludge;
{
    local $Storable::interwork_56_64bit = 1;
    $test_kludge = freeze \'Heck';
}

my $header_kludge = Storable::read_magic ($test_kludge);

cmp_ok (length ($header_kludge->{byteorder}), '==', $Config{longsize},
        "With 5.6 interwork kludge byteorder string should be same size as long"
       );
$result = eval {thaw $test_kludge};
is ($result, undef, "By default should not be able to thaw");
like ($@, qr/Byte order is not compatible/,
      "because the header byte order strings differ");

$result = eval {thaw $test};
isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
is ($@, '', "        causes no errors");
is ($$result, 'Hell', "        and gives the expected data");

{
    local $Storable::interwork_56_64bit = 1;

    $result = eval {thaw $test_kludge};
    isa_ok ($result, 'SCALAR', "should be able to thaw kludge data");
    is ($@, '', "with no errors");
    is ($$result, 'Heck', "and gives expected data");

    $result = eval {thaw $test};
    is ($result, undef, "But now can't thaw real data");
    like ($@, qr/Byte order is not compatible/,
          "because the header byte order strings differ");
}

#  All together now:
$result = eval {thaw $test};
isa_ok ($result, 'SCALAR', "CHORUS: check thawing test data");
is ($@, '', "        causes no errors");
is ($$result, 'Hell', "        and gives the expected data");

__END__
# A whole run of 1.1.14 freeze data, uuencoded. The "mode bits" are the octal
# value of 'A', the "file name" is the test name. Use make_56_interwork.pl
# with a copy of Storable 1.X generate these.

# byteorder      '1234'
# sizeof(int)    4
# sizeof(long)   4
# sizeof(char *) 4
# sizeof(NV)     8
begin 101 Lillput,4,4,4,8
M!`0$,3(S-`0$!`@"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87,@8V]R<F5C=`8"
0````````@`H'5&AE($5N9```

end

# byteorder      '4321'
# sizeof(int)    4
# sizeof(long)   4
# sizeof(char *) 4
# sizeof(NV)     8
begin 101 Belfuscu,4,4,4,8
M!`0$-#,R,00$!`@"````!`HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H40F5L9G5S8W4@=V%S(&-O<G)E8W0&
1@`````````(*!U1H92!%;F0`

end

# byteorder      '1234'
# sizeof(int)    4
# sizeof(long)   4
# sizeof(char *) 4
# sizeof(NV)     12
begin 101 Lillput,4,4,4,12
M!`0$,3(S-`0$!`P"!`````HQ5&AI<R!F:6QE('=A<R!W<FET=&5N('=I=&@@
M,2XP,30@;VX@<&5R;"`U+C`P-C`P,0H33&EL;'!U="!W87,@8V]R<F5C=`8"
0````````@`H'5&AE($5N9```

end

Name	Type	Size	Permission
CVE-2015-1592.t	File	534 B	0644
HAS_ATTACH.pm	File	121 B	0644
HAS_HOOK.pm	File	82 B	0644
HAS_OVERLOAD.pm	File	185 B	0644
attach.t	File	1007 B	0644
attach_errors.t	File	6.64 KB	0644
attach_singleton.t	File	2.5 KB	0644
blessed.t	File	10.52 KB	0644
canonical.t	File	3.46 KB	0644
circular_hook.t	File	1.98 KB	0644
code.t	File	7.29 KB	0644
compat01.t	File	1.15 KB	0644
compat06.t	File	3.25 KB	0644
croak.t	File	949 B	0644
dclone.t	File	2.28 KB	0644
destroy.t	File	366 B	0644
downgrade.t	File	15.76 KB	0644
file_magic.t	File	13.23 KB	0644
flags.t	File	2.32 KB	0644
forgive.t	File	1.52 KB	0644
freeze.t	File	2.55 KB	0644
huge.t	File	3.22 KB	0644
hugeids.t	File	7.61 KB	0644
integer.t	File	5.81 KB	0644
interwork56.t	File	5.95 KB	0644
just_plain_nasty.t	File	4.29 KB	0644
leaks.t	File	845 B	0644
lock.t	File	1.01 KB	0644
make_56_interwork.pl	File	1.45 KB	0644
make_downgrade.pl	File	2.09 KB	0644
make_overload.pl	File	177 B	0644
malice.t	File	10.33 KB	0644
overload.t	File	2.08 KB	0644
recurse.t	File	7.92 KB	0644
regexp.t	File	3.66 KB	0644
restrict.t	File	3.49 KB	0644
retrieve.t	File	3.02 KB	0644
robust.t	File	309 B	0644
sig_die.t	File	734 B	0644
st-dump.pl	File	3.35 KB	0644
store.t	File	3.25 KB	0644
testlib.pl	File	863 B	0644
threads.t	File	1.93 KB	0644
tied.t	File	4.15 KB	0644
tied_hook.t	File	4.63 KB	0644
tied_items.t	File	1.11 KB	0644
tied_reify.t	File	621 B	0644
tied_store.t	File	924 B	0644
utf8.t	File	1.17 KB	0644
utf8hash.t	File	5.31 KB	0644
weak.t	File	3.72 KB	0644

Upload:

Command:

Filemanager

Server Info

System Info