view release on metacpan or  search on metacpan

t/000-report-versions.t  view on Meta::CPAN

# Printable characters for escapes
my %UNESCAPES = (
    z    => "\x00",
    a    => "\x07",
    t    => "\x09",
    n    => "\x0a",
    v    => "\x0b",
    f    => "\x0c",
    r    => "\x0d",
    e    => "\x1b",
    '\\' => '\\',
);

#####################################################################
# Implementation

# Create an empty YAML::Tiny object
sub new {
    my $class = shift;
    bless [@_], $class;
}

# Create an object from a file
sub read {
    my $class = ref $_[0] ? ref shift : shift;

    # Check the file
    my $file = shift
        or return $class->_error('You did not specify a file name');
    return $class->_error("File '$file' does not exist") unless -e $file;
    return $class->_error("'$file' is a directory, not a file") unless -f _;
    return $class->_error("Insufficient permissions to read '$file'")
        unless -r _;

    # Slurp in the file
    local $/ = undef;
    local *CFG;
    unless ( open( CFG, $file ) ) {
        return $class->_error("Failed to open file '$file': $!");
    }
    my $contents = <CFG>;
    unless ( close(CFG) ) {
        return $class->_error("Failed to close file '$file': $!");
    }

    $class->read_string($contents);
}

# Create an object from a string
sub read_string {
    my $class = ref $_[0] ? ref shift : shift;
    my $self = bless [], $class;
    my $string = $_[0];
    unless ( defined $string ) {
        return $self->_error("Did not provide a string to load");
    }

    # Byte order marks
    # NOTE: Keeping this here to educate maintainers
    # my %BOM = (
    #     "\357\273\277" => 'UTF-8',
    #     "\376\377"     => 'UTF-16BE',
    #     "\377\376"     => 'UTF-16LE',
    #     "\377\376\0\0" => 'UTF-32LE'
    #     "\0\0\376\377" => 'UTF-32BE',
    # );
    if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
        return $self->_error("Stream has a non UTF-8 BOM");
    }
    else {
        # Strip UTF-8 bom if found, we'll just ignore it
        $string =~ s/^\357\273\277//;
    }

    # Try to decode as utf8
    utf8::decode($string) if HAVE_UTF8;

    # Check for some special cases
    return $self unless length $string;
    unless ( $string =~ /[\012\015]+\z/ ) {
        return $self->_error("Stream does not end with newline character");
    }

    # Split the file into lines
    my @lines = grep { !/^\s*(?:\#.*)?\z/ }
        split /(?:\015{1,2}\012|\015|\012)/, $string;

    # Strip the initial YAML header
    @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;

    # A nibbling parser
    while (@lines) {

        # Do we have a document header?
        if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {

            # Handle scalar documents
            shift @lines;
            if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
                push @$self, $self->_read_scalar( "$1", [undef], \@lines );
                next;
            }
        }

        if ( !@lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {

            # A naked document
            push @$self, undef;
            while ( @lines and $lines[0] !~ /^---/ ) {
                shift @lines;
            }

        }
        elsif ( $lines[0] =~ /^\s*\-/ ) {

            # An array at the root
            my $document = [];
            push @$self, $document;
            $self->_read_array( $document, [0], \@lines );

        }
        elsif ( $lines[0] =~ /^(\s*)\S/ ) {

            # A hash at the root
            my $document = {};
            push @$self, $document;
            $self->_read_hash( $document, [ length($1) ], \@lines );