view release on metacpan or  search on metacpan

t/002-main.t  view on Meta::CPAN

            # say sprintf "yyyy 0x%X $count $valuesString $len ", $offset;

            seek($fh, $offset, SEEK_SET)
                or die "Cannot seek to $offset: $!\n";
            read($fh, my $data, $len) == $len
                or die "Error reading $len bytes @ offset $offset: $!\n";
            $data eq $binaryValue
                or die sprintf "Binary mismatch in $filename \@ 0x%X : Got[%s] Want[$valuesString]",
                        $offset,
                        unpack("H*", $data);

            $offset += length($binaryValue);

        }
    }

    ok 1, 'Bytes Match';
    return 1;
}

sub parseControl
{
    my $directory = shift;

    my $filename = "$directory/control";

    state $keywords = { map { $_ => 1}
                        qw( exit-status stdout stderr )
                      };

    return ( '' => {
                    'exit-status' => 0,
                    'stdout'      => 'stdout',
                    'stderr'      => '',
                    },
            '-v' => {
                    'exit-status' => 0,
                    'stdout'      => 'stdout-v',
                    'stderr'      => '',
                    }
            )
        if !-e $filename ;

    # default
    #     exit-status 0
    #     stdout      stdout
    #     stderr      NULL
    #
    # -v --walk
    #     exit-status 0
    #     stdout      stdout-v
    #     stderr      NULL
    #
    # -v --walk --redact
    #     same-as     -v --walk

    my @records ;
    my %results;

    {
        local $/ = ""; # paragraph mode

        open my $fh, '<', $filename
            or die "Cannot open '$filename': $!\n";

        @records = map { [ split "\n", $_ ] }
                   <$fh>;

        close $fh;
    }

    for my $record (@records)
    {
        my @lines = grep { ! /^\s*$/ && ! /^\s*#/ }
                    @$record;

        my $type = shift @lines;
        $type =~ s/\s+//g;
        $type = ''
            if lc $type eq 'default';

        for my $line (@lines)
        {
            next if $line =~ /^\s*$/;
            $line =~ /^\s*(\S+)\s+(.+)/;
            my $keyword = lc $1;
            my $value = $2;

            $value = ''
                if lc $value eq 'null';

            die "Invalid keyword '$keyword' in $filename\n"
                unless $keywords->{$keyword} ;

            $results{$type}{$keyword} = $value;
        }
    }

    return %results;

}


sub getNativeLocale
{
    state $enc;

    if (! $enc)
    {
        $enc = 'unknown';

        eval
        {
            require encoding ;
            my $encoding = encoding::_get_locale_encoding() // 'cp437';
            $enc = Encode::find_encoding($encoding) ;
        } ;

        $enc = $enc->name()
            if $enc;
    }