Data::YAML::Reader - Parse YAML created by Data::YAML::Writer

    use Data::YAML::Reader;

    my $yr = Data::YAML::Reader->new;

    # Read from an array...
    my $from_array = $yr->read( \@some_array );

    # ...an open file handle...
    my $from_handle = $yr->read( $some_file );

    # ...a string containing YAML...
    my $from_string = $yr->read( $some_string );

    # ...or a closure
    my $from_code = $yr->read( sub { return get_next_line() } );

package Data::YAML::Reader;

use strict;
use warnings;
use Carp;

use vars qw{$VERSION};

$VERSION = '0.0.6';

# TODO:
#   Handle blessed object syntax

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

my $QQ_STRING = qr{ " (?:\\. | [^"])* " }x;
my $HASH_LINE = qr{ ^ ($QQ_STRING|\S+) \s* : (?: \s+ (.+?) \s* )? $ }x;
my $IS_HASH_KEY  = qr{ ^ [\w\'\"] }x;
my $IS_END_YAML  = qr{ ^ [.][.][.] \s* $ }x;
my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x;

# Create an empty Data::YAML::Reader object
sub new {
  my $class = shift;
  bless {}, $class;
}

sub _make_reader {
  my $self = shift;
  my $obj  = shift;

  croak "Must have something to read from"
   unless defined $obj;

  if ( my $ref = ref $obj ) {
    if ( 'CODE' eq $ref ) {
      return $obj;
    }
    elsif ( 'ARRAY' eq $ref ) {
      return sub { shift @$obj };
    }
    elsif ( 'SCALAR' eq $ref ) {
      return $self->_make_reader( $$obj );
    }
    elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) {
      return sub {
        my $line = <$obj>;
        chomp $line if defined $line;
        return $line;
      };
    }
    croak "Don't know how to read $ref";
  }
  else {
    my @lines = split( /\n/, $obj );
    return sub { shift @lines };
  }
}

sub read {
  my $self = shift;
  my $obj  = shift;

  $self->{reader}  = $self->_make_reader( $obj );
  $self->{capture} = [];

  # Prime the reader
  $self->_next;

  my $doc = $self->_read;

  # The terminator is mandatory otherwise we'd consume a line from the
  # iterator that doesn't belong to us. If we want to remove this
  # restriction we'll have to implement look-ahead in the iterators.
  # Which might not be a bad idea.
  my $dots = $self->_peek;
  croak "Missing '...' at end of YAML"
   unless $dots =~ $IS_END_YAML;

  delete $self->{reader};
  delete $self->{next};

  return $doc;
}

sub get_raw {
  my $self = shift;

  if ( defined( my $capture = $self->{capture} ) ) {
    return join( "\n", @$capture ) . "\n";
  }

  return '';
}

sub _peek {
  my $self = shift;
  return $self->{next} unless wantarray;
  my $line = $self->{next};
  $line =~ /^ (\s*) (.*) $ /x;
  return ( $2, length $1 );
}

sub _next {
  my $self = shift;
  croak "_next called with no reader"
   unless $self->{reader};
  my $line = $self->{reader}->();
  $self->{next} = $line;
  push @{ $self->{capture} }, $line;
}

sub _read {
  my $self = shift;

  my $line = $self->_peek;

  # Do we have a document header?
  if ( $line =~ /^ --- (?: \s* (.+?) \s* )? $/x ) {
    $self->_next;

    return $self->_read_scalar( $1 ) if defined $1;    # Inline?

    my ( $next, $indent ) = $self->_peek;

    if ( $next =~ /^ - /x ) {
      return $self->_read_array( $indent );
    }
    elsif ( $next =~ $IS_HASH_KEY ) {
      return $self->_read_hash( $next, $indent );
    }
    elsif ( $next =~ $IS_END_YAML ) {
      croak "Premature end of YAML";
    }
    else {
      croak "Unsupported YAML syntax: '$next'";
    }
  }
  else {
    croak "YAML document header not found";
  }
}

# Parse a double quoted string
sub _read_qq {
  my $self = shift;
  my $str  = shift;

  unless ( $str =~ s/^ " (.*?) " $/$1/x ) {
    die "Internal: not a quoted string";
  }

  $str =~ s/\\"/"/gx;
  $str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) ) 
                                  / (length($1) > 1) ? pack("H2", $2) : $UNESCAPES{$1} /gex;
  return $str;
}

# Parse a scalar string to the actual scalar
sub _read_scalar {
  my $self   = shift;
  my $string = shift;

  return undef if $string eq '~';

  if ( $string eq '>' || $string eq '|' ) {

    my ( $line, $indent ) = $self->_peek;
    die "Multi-line scalar content missing" unless defined $line;

    my @multiline = ( $line );

    while ( 1 ) {
      $self->_next;
      my ( $next, $ind ) = $self->_peek;
      last if $ind < $indent;
      push @multiline, $next;
    }

    return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n";
  }

  if ( $string =~ /^ ' (.*) ' $/x ) {
    ( my $rv = $1 ) =~ s/''/'/g;
    return $rv;
  }

  if ( $string =~ $IS_QQ_STRING ) {
    return $self->_read_qq( $string );
  }

  if ( $string =~ /^['"]/ ) {

    # A quote with folding... we don't support that
    die __PACKAGE__ . " does not support multi-line quoted scalars";
  }

  # Regular unquoted string
  return $string;
}

sub _read_nested {
  my $self = shift;

  my ( $line, $indent ) = $self->_peek;

  if ( $line =~ /^ -/x ) {
    return $self->_read_array( $indent );
  }
  elsif ( $line =~ $IS_HASH_KEY ) {
    return $self->_read_hash( $line, $indent );
  }
  else {
    croak "Unsupported YAML syntax: '$line'";
  }
}

# Parse an array
sub _read_array {
  my ( $self, $limit ) = @_;

  my $ar = [];

  while ( 1 ) {
    my ( $line, $indent ) = $self->_peek;
    last if $indent < $limit || !defined $line || $line =~ $IS_END_YAML;

    if ( $indent > $limit ) {
      croak "Array line over-indented";
    }

    if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) {
      $indent += length $1;
      $line =~ s/-\s+//;
      push @$ar, $self->_read_hash( $line, $indent );
    }
    elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) {
      croak "Unexpected start of YAML" if $line =~ /^---/;
      $self->_next;
      push @$ar, $self->_read_scalar( $1 );
    }
    elsif ( $line =~ /^ - \s* $/x ) {
      $self->_next;
      push @$ar, $self->_read_nested;
    }
    elsif ( $line =~ $IS_HASH_KEY ) {
      $self->_next;
      push @$ar, $self->_read_hash( $line, $indent, );
    }
    else {
      croak "Unsupported YAML syntax: '$line'";
    }
  }

  return $ar;
}

sub _read_hash {
  my ( $self, $line, $limit ) = @_;

  my $indent;
  my $hash = {};

  while ( 1 ) {
    croak "Badly formed hash line: '$line'"
     unless $line =~ $HASH_LINE;

    my ( $key, $value ) = ( $self->_read_scalar( $1 ), $2 );
    $self->_next;

    if ( defined $value ) {
      $hash->{$key} = $self->_read_scalar( $value );
    }
    else {
      $hash->{$key} = $self->_read_nested;
    }

    ( $line, $indent ) = $self->_peek;
    last if $indent < $limit || !defined $line || $line =~ $IS_END_YAML;
  }

  return $hash;
}

1;

__END__