view release on metacpan or  search on metacpan

scripts/dex  view on Meta::CPAN

                      }
                  $self->push_tokens(\@tokens);
                  $self->exception("Missing closing quote <$context> or invalid document marker");
              }
              elsif ((length $spaces) < $indent) {
                  for (my $i = 0; $i < @tokens; $i+= 3) {
                      my $token = $tokens[ $i + 1 ];
                      if (ref $token) {
                          $tokens[ $i + 1 ] = $token->{orig};
                      }
                  }
                  $self->push_tokens(\@tokens);
                  $self->exception("Wrong indendation or missing closing quote <$context>");
              }
  
              if ($$yaml =~ s/\A($RE_WS+)//) {
                  $spaces .= $1;
              }
              push @tokens, ( WS => $spaces, $self->line );
          }
  
          my $v = $self->_read_quoted_tokens($start, $context, $yaml, \@tokens);
          push @values, $v;
          if ($tokens[-3] eq $token_name) {
              if ($start) {
                  $self->push_subtokens(
                      { name => 'QUOTED', value => $v->{value} }, \@tokens
                  );
              }
              else {
                  my $value = YAML::PP::Render->render_quoted($context, \@values);
                  $self->push_subtokens(
                      { name => 'QUOTED_MULTILINE', value => $value }, \@tokens
                  );
              }
              $self->set_context(1) if $self->flowcontext;
              if (length $$yaml) {
                  my $partial = $self->_fetch_next_tokens($next_line);
                  if (not $partial) {
                      $self->set_next_line(undef);
                  }
                  return 0;
              }
              else {
                  @tokens = ();
                  push @tokens, ( EOL => $next_line->[2], $self->line );
                  $self->push_tokens(\@tokens);
                  $self->set_next_line(undef);
                  return;
              }
          }
          $tokens[-2] .= $next_line->[2];
          $self->set_next_line(undef);
          $start = 0;
      }
  }
  
  sub _read_quoted_tokens {
      my ($self, $start, $first, $yaml, $tokens) = @_;
      my $quoted = '';
      my $decoded = '';
      my $token_name = $TOKEN_NAMES{ $first };
      if ($first eq "'") {
          my $regex = $REGEXES{SINGLEQUOTED};
          if ($$yaml =~ s/\A($regex)//) {
              $quoted .= $1;
              $decoded .= $1;
              $decoded =~ s/''/'/g;
          }
      }
      else {
          ($quoted, $decoded) = $self->_read_doublequoted($yaml);
      }
      my $eol = '';
      unless (length $$yaml) {
          if ($quoted =~ s/($RE_WS+)\z//) {
              $eol = $1;
              $decoded =~ s/($eol)\z//;
          }
      }
      my $value = { value => $decoded, orig => $quoted };
  
      if ($$yaml =~ s/\A$first//) {
          if ($start) {
              push @$tokens, ( $token_name . 'D' => $value, $self->line );
          }
          else {
              push @$tokens, ( $token_name . 'D_LINE' => $value, $self->line );
          }
          push @$tokens, ( $token_name => $first, $self->line );
          return $value;
      }
      if (length $$yaml) {
          push @$tokens, ( $token_name . 'D' => $value->{orig}, $self->line );
          $self->push_tokens($tokens);
          $self->exception("Invalid quoted <$first> string");
      }
  
      push @$tokens, ( $token_name . 'D_LINE' => $value, $self->line );
      push @$tokens, ( EOL => $eol, $self->line );
  
      return $value;
  }
  
  sub _read_doublequoted {
      my ($self, $yaml) = @_;
      my $quoted = '';
      my $decoded = '';
      while (1) {
          my $last = 1;
          if ($$yaml =~ s/\A([^"\\]+)//) {
              $quoted .= $1;
              $decoded .= $1;
              $last = 0;
          }
          if ($$yaml =~ s/\A($RE_ESCAPES)//) {
              $quoted .= $1;
              my $dec = defined $2 ? $CONTROL{ $2 }
                          : defined $3 ? chr hex $3
                          : defined $4 ? chr hex $4
                          : chr hex $5;
              $decoded .= $dec;
              $last = 0;
          }
          if ($$yaml =~ s/\A(\\)\z//) {
              $quoted .= $1;
              $decoded .= $1;
              last;
          }
          last if $last;
      }
      return ($quoted, $decoded);
  }
  
  sub _fetch_next_tokens_directive {
      my ($self, $yaml, $eol) = @_;
      my @tokens;
  
      if ($$yaml =~ s/\A(\s*%YAML)//) {
          my $dir = $1;
          if ($$yaml =~ s/\A( )//) {
              $dir .= $1;
              if ($$yaml =~ s/\A(1\.[12]$RE_WS*)//) {
                  $dir .= $1;
                  push @tokens, ( YAML_DIRECTIVE => $dir, $self->line );
              }
              else {
                  $$yaml =~ s/\A(.*)//;
                  $dir .= $1;
                  my $warn = $ENV{YAML_PP_RESERVED_DIRECTIVE} || 'warn';
                  if ($warn eq 'warn') {
                      warn "Found reserved directive '$dir'";
                  }
                  elsif ($warn eq 'fatal') {
                      die "Found reserved directive '$dir'";
                  }
                  push @tokens, ( RESERVED_DIRECTIVE => "$dir", $self->line );
              }
          }
          else {
              $$yaml =~ s/\A(.*)//;
              $dir .= $1;
              push @tokens, ( 'Invalid directive' => $dir, $self->line );
              push @tokens, ( EOL => $eol, $self->line );
              $self->push_tokens(\@tokens);
              return;
          }
      }
      elsif ($$yaml =~ s/\A(\s*%TAG +(!$RE_NS_WORD_CHAR*!|!) +(tag:\S+|!$RE_URI_CHAR+)$RE_WS*)//) {
          push @tokens, ( TAG_DIRECTIVE => $1, $self->line );
          # TODO
          my $tag_alias = $2;
          my $tag_url = $3;
      }
      elsif ($$yaml =~ s/\A(\s*\A%(?:\w+).*)//) {
          push @tokens, ( RESERVED_DIRECTIVE => $1, $self->line );
          my $warn = $ENV{YAML_PP_RESERVED_DIRECTIVE} || 'warn';
          if ($warn eq 'warn') {
              warn "Found reserved directive '$1'";
          }
          elsif ($warn eq 'fatal') {
              die "Found reserved directive '$1'";
          }
      }
      else {
          push @tokens, ( 'Invalid directive' => $$yaml, $self->line );
          push @tokens, ( EOL => $eol, $self->line );
          $self->push_tokens(\@tokens);
          return;
      }
      if (not length $$yaml) {
          push @tokens, ( EOL => $eol, $self->line );

scripts/dex  view on Meta::CPAN

      $schema->add_representer(
          regex => qr{.*},
          code => sub {
              my ($rep, $node) = @_;
              my $binary = $node->{value};
              unless ($binary =~ m/[\x{7F}-\x{10FFFF}]/) {
                  # ASCII
                  return;
              }
              if (utf8::is_utf8($binary)) {
                  # utf8
                  return;
              }
              # everything else must be base64 encoded
              my $base64 = encode_base64($binary);
              $node->{style} = YAML_ANY_SCALAR_STYLE;
              $node->{data} = $base64;
              $node->{tag} = "tag:yaml.org,2002:binary";
              return 1;
          },
      );
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding utf-8
  
  =head1 NAME
  
  YAML::PP::Schema::Binary - Schema for loading and binary data
  
  =head1 SYNOPSIS
  
      use YAML::PP;
      my $yp = YAML::PP->new( schema => [qw/ + Binary /] );
      # or
  
      my ($binary, $same_binary) = $yp->load_string(<<'EOM');
      --- !!binary "\
        R0lGODlhDAAMAIQAAP//9/X17unp5WZmZgAAAOfn515eXvPz7Y6OjuDg4J+fn5\
        OTk6enp56enmlpaWNjY6Ojo4SEhP/++f/++f/++f/++f/++f/++f/++f/++f/+\
        +f/++f/++f/++f/++f/++SH+Dk1hZGUgd2l0aCBHSU1QACwAAAAADAAMAAAFLC\
        AgjoEwnuNAFOhpEMTRiggcz4BNJHrv/zCFcLiwMWYNG84BwwEeECcgggoBADs="
      --- !!binary |
        R0lGODlhDAAMAIQAAP//9/X17unp5WZmZgAAAOfn515eXvPz7Y6OjuDg4J+fn5
        OTk6enp56enmlpaWNjY6Ojo4SEhP/++f/++f/++f/++f/++f/++f/++f/++f/+
        +f/++f/++f/++f/++f/++SH+Dk1hZGUgd2l0aCBHSU1QACwAAAAADAAMAAAFLC
        AgjoEwnuNAFOhpEMTRiggcz4BNJHrv/zCFcLiwMWYNG84BwwEeECcgggoBADs=
      # The binary value above is a tiny arrow encoded as a gif image.
      EOM
  
  =head1 DESCRIPTION
  
  See <https://yaml.org/type/binary.html>
  
  By prepending a base64 encoded binary string with the C<!!binary> tag, it can
  be automatically decoded when loading.
  
  Note that the logic for dumping is probably broken, see
  L<https://github.com/perlpunk/YAML-PP-p5/issues/28>.
  
  Suggestions welcome.
  
  =head1 METHODS
  
  =over
  
  =item register
  
  Called by L<YAML::PP::Schema>
  
  =back
  
  =cut
YAML_PP_SCHEMA_BINARY

$fatpacked{"YAML/PP/Schema/Core.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'YAML_PP_SCHEMA_CORE';
  use strict;
  use warnings;
  package YAML::PP::Schema::Core;
  
  our $VERSION = '0.027'; # VERSION
  
  use YAML::PP::Schema::JSON qw/
      represent_int represent_float represent_literal represent_bool
      represent_undef
  /;
  
  use B;
  
  use YAML::PP::Common qw/ YAML_PLAIN_SCALAR_STYLE /;
  
  my $RE_INT_CORE = qr{^([+-]?(?:[0-9]+))$};
  my $RE_FLOAT_CORE = qr{^([+-]?(?:\.[0-9]+|[0-9]+(?:\.[0-9]*)?)(?:[eE][+-]?[0-9]+)?)$};
  my $RE_INT_OCTAL = qr{^0o([0-7]+)$};
  my $RE_INT_HEX = qr{^0x([0-9a-fA-F]+)$};
  
  sub _from_oct { oct $_[2]->[0] }
  sub _from_hex { hex $_[2]->[0] }
  
  sub register {
      my ($self, %args) = @_;
      my $schema = $args{schema};
  
      $schema->add_resolver(
          tag => 'tag:yaml.org,2002:null',
          match => [ equals => $_ => undef ],
      ) for (qw/ null NULL Null ~ /, '');
      $schema->add_resolver(
          tag => 'tag:yaml.org,2002:bool',
          match => [ equals => $_ => $schema->true ],
      ) for (qw/ true TRUE True /);
      $schema->add_resolver(
          tag => 'tag:yaml.org,2002:bool',
          match => [ equals => $_ => $schema->false ],
      ) for (qw/ false FALSE False /);
      $schema->add_resolver(