view release on metacpan or  search on metacpan

scripts/dex  view on Meta::CPAN

          my $value = $new_tokens->[ $i + 1 ];
          my $name = $new_tokens->[ $i ];
          my $line = $new_tokens->[ $i + 2 ];
          my $push = {
              name => $name,
              line => $line,
              column => $column,
              value => $value,
          };
          $column += length $value unless $name eq 'CONTEXT';
          push @$next, $push;
          if ($name eq 'EOL') {
              $column = 0;
          }
      }
      $self->set_offset($column);
      return $next;
  }
  
  sub push_subtokens {
      my ($self, $token, $subtokens) = @_;
      my $next = $self->next_tokens;
      my $line = $self->line;
      my $column = $self->offset;
      $token->{column} = $column;
      $token->{subtokens} = \my @sub;
  
      for (my $i = 0; $i < @$subtokens; $i+=3) {
          my $name = $subtokens->[ $i ];
          my $value = $subtokens->[ $i + 1 ];
          my $line = $subtokens->[ $i + 2 ];
          my $push = {
              name => $subtokens->[ $i ],
              line => $line,
              column => $column,
          };
          if (ref $value eq 'HASH') {
              %$push = ( %$push, %$value );
              $column += length $value->{orig};
          }
          else {
              $push->{value} = $value;
              $column += length $value;
          }
          if ($push->{name} eq 'EOL') {
              $column = 0;
          }
          push @sub, $push;
      }
      $token->{line} = $sub[0]->{line};
      push @$next, $token;
      $self->set_offset($column);
      return $next;
  }
  
  sub exception {
      my ($self, $msg) = @_;
      my $next = $self->next_tokens;
      $next = [];
      my $line = @$next ? $next->[0]->{line} : $self->line;
      my @caller = caller(0);
      my $yaml = '';
      if (my $nl = $self->next_line) {
          $yaml = join '', @$nl;
          $yaml = $nl->[1];
      }
      my $e = YAML::PP::Exception->new(
          line => $line,
          column => $self->offset + 1,
          msg => $msg,
          next => $next,
          where => $caller[1] . ' line ' . $caller[2],
          yaml => $yaml,
      );
      croak $e;
  }
  
  1;
YAML_PP_LEXER

$fatpacked{"YAML/PP/Loader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'YAML_PP_LOADER';
  # ABSTRACT: Load YAML into data with Parser and Constructor
  use strict;
  use warnings;
  package YAML::PP::Loader;
  
  our $VERSION = '0.027'; # VERSION
  
  use YAML::PP::Parser;
  use YAML::PP::Constructor;
  use YAML::PP::Reader;
  
  sub new {
      my ($class, %args) = @_;
  
      my $cyclic_refs = delete $args{cyclic_refs} || 'allow';
      my $default_yaml_version = delete $args{default_yaml_version} || '1.2';
      my $preserve = delete $args{preserve};
      my $duplicate_keys = delete $args{duplicate_keys};
      my $schemas = delete $args{schemas};
      $schemas ||= {
          '1.2' => YAML::PP->default_schema(
              boolean => 'perl',
          )
      };
  
      my $constructor = delete $args{constructor} || YAML::PP::Constructor->new(
          schemas => $schemas,
          cyclic_refs => $cyclic_refs,
          default_yaml_version => $default_yaml_version,
          preserve => $preserve,
          duplicate_keys => $duplicate_keys,
      );
      my $parser = delete $args{parser};
      unless ($parser) {
          $parser = YAML::PP::Parser->new(
              default_yaml_version => $default_yaml_version,
          );
      }
      unless ($parser->receiver) {
          $parser->set_receiver($constructor);

scripts/dex  view on Meta::CPAN

              else {
                  if (ref $first eq 'ARRAY') {
                      $first = $first->[0];
                  }
                  $self->info("TYPE $first");
              }
          }
          else {
              eval {
                  my @keys = sort keys %$rule;
                  $self->info("@keys");
              };
          }
      }
  }
  
  sub debug_tokens {
      my ($self, $tokens) = @_;
      $tokens ||= $self->tokens;
      require Term::ANSIColor;
      for my $token (@$tokens) {
          my $type = Term::ANSIColor::colored(["green"],
              sprintf "%-22s L %2d C %2d ",
                  $token->{name}, $token->{line}, $token->{column} + 1
          );
          local $Data::Dumper::Useqq = 1;
          local $Data::Dumper::Terse = 1;
          require Data::Dumper;
          my $str = Data::Dumper->Dump([$token->{value}], ['str']);
          chomp $str;
          $str =~ s/(^.|.$)/Term::ANSIColor::colored(['blue'], $1)/ge;
          warn "$type$str\n";
      }
  
  }
  
  sub highlight_yaml {
      my ($self) = @_;
      require YAML::PP::Highlight;
      my $tokens = $self->tokens;
      my $highlighted = YAML::PP::Highlight->ansicolored($tokens);
      warn $highlighted;
  }
  
  sub exception {
      my ($self, $msg, %args) = @_;
      my $next = $self->lexer->next_tokens;
      my $line = @$next ? $next->[0]->{line} : $self->lexer->line;
      my $offset = @$next ? $next->[0]->{column} : $self->lexer->offset;
      $offset++;
      my $next_line = $self->lexer->next_line;
      my $remaining = '';
      if ($next_line) {
          if ($self->lexer->offset > 0) {
              $remaining = $next_line->[1] . $next_line->[2];
          }
          else {
              $remaining = join '', @$next_line;
          }
      }
      my $caller = $args{caller} || [ caller(0) ];
      my $e = YAML::PP::Exception->new(
          got => $args{got},
          expected => $args{expected},
          line => $line,
          column => $offset,
          msg => $msg,
          next => $next,
          where => $caller->[1] . ' line ' . $caller->[2],
          yaml => $remaining,
      );
      croak $e;
  }
  
  sub expected {
      my ($self, %args) = @_;
      my $expected = $args{expected};
      @$expected = sort grep { m/^[A-Z_]+$/ } @$expected;
      my $got = $args{got}->{name};
      my @caller = caller(0);
      $self->exception("Expected (@$expected), but got $got",
          caller => \@caller,
          expected => $expected,
          got => $args{got},
      );
  }
  
  sub cb_tag {
      my ($self, $token) = @_;
      my $stack = $self->event_stack;
      if (! @$stack or $stack->[-1]->[0] ne 'properties') {
          push @$stack, [ properties => {} ];
      }
      my $last = $stack->[-1]->[1];
      my $tag = $self->_read_tag($token->{value}, $self->tagmap);
      $last->{inline} ||= [];
      push @{ $last->{inline} }, {
          type => 'tag',
          value => $tag,
          offset => $token->{column},
      };
  }
  
  sub _read_tag {
      my ($self, $tag, $map) = @_;
      if ($tag eq '!') {
          return "!";
      }
      elsif ($tag =~ m/^!<(.*)>/) {
          return $1;
      }
      elsif ($tag =~ m/^(![^!]*!|!)(.+)/) {
          my $alias = $1;
          my $name = $2;
          $name =~ s/%([0-9a-fA-F]{2})/chr hex $1/eg;
          if (exists $map->{ $alias }) {
              $tag = $map->{ $alias }. $name;
          }
          else {
              if ($alias ne '!' and $alias ne '!!') {
                  die "Found undefined tag handle '$alias'";
              }
              $tag = "!$name";
          }
      }
      else {
          die "Invalid tag";
      }
      return $tag;
  }
  
  sub cb_anchor {
      my ($self, $token) = @_;
      my $anchor = $token->{value};
      $anchor = substr($anchor, 1);
      my $stack = $self->event_stack;
      if (! @$stack or $stack->[-1]->[0] ne 'properties') {
          push @$stack, [ properties => {} ];
      }
      my $last = $stack->[-1]->[1];