App-Dex

 view release on metacpan or  search on metacpan

scripts/dex  view on Meta::CPAN

          }
          elsif ($value =~ m/[: \t]\z/) {
              $style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
          }
          elsif ($value =~ m/[^\x20-\x3A\x3B-\x7E\x85\xA0-\x{D7FF}\x{E000}-\x{FEFE}\x{FF00}-\x{FFFD}\x{10000}-\x{10FFFF}]/) {
              $style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
          }
          elsif ($forbidden_first_plus_space{ $first }) {
              if (length ($value) == 1 or substr($value, 1, 1) =~ m/^\s/) {
                  $style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
              }
          }
      }
      if ($style == YAML_SINGLE_QUOTED_SCALAR_STYLE and not $info->{style}) {
          if ($value =~ tr/'// and $value !~ tr/"//) {
              $style = YAML_DOUBLE_QUOTED_SCALAR_STYLE;
          }
      }
  
      my $open_ended = 0;
  
      if ($style == YAML_PLAIN_SCALAR_STYLE) {
          $value =~ s/\n/\n\n/g;
      }
      elsif ($style == YAML_SINGLE_QUOTED_SCALAR_STYLE) {
          my $new_indent = $last->{indent} . (' ' x $self->indent);
          $value =~ s/(\n+)/"\n" x (1 + (length $1))/eg;
          my @lines = split m/\n/, $value, -1;
          if (@lines > 1) {
              for my $line (@lines[1 .. $#lines]) {
                  $line = $new_indent . $line
                      if length $line;
              }
          }
          $value = join "\n", @lines;
          $value =~ s/'/''/g;
          $value = "'" . $value . "'";
      }
      elsif ($style == YAML_LITERAL_SCALAR_STYLE) {
          DEBUG and warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$value], ['value']);
          my $indicators = '';
          if ($value =~ m/\A\n* +/) {
              $indicators .= $self->indent;
          }
          my $indent = $indent . ' ' x $self->indent;
          if ($value !~ m/\n\z/) {
              $indicators .= '-';
              $value .= "\n";
          }
          elsif ($value =~ m/(\n|\A)\n\z/) {
              $indicators .= '+';
              $open_ended = 1;
          }
          $value =~ s/^(?=.)/$indent/gm;
          $value = "|$indicators\n$value";
      }
      elsif ($style == YAML_FOLDED_SCALAR_STYLE) {
          DEBUG and warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$value], ['value']);
          my @lines = split /\n/, $value, -1;
          DEBUG and warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@lines], ['lines']);
          my $eol = 0;
          my $indicators = '';
          if ($value =~ m/\A\n* +/) {
              $indicators .= $self->indent;
          }
          my $indent = $indent . ' ' x $self->indent;
          if ($lines[-1] eq '') {
              pop @lines;
              $eol = 1;
          }
          else {
              $indicators .= '-';
          }
          $value = ">$indicators\n";
          for my $i (0 .. $#lines) {
              my $line = $lines[ $i ];
              if (length $line) {
                  $value .= "$indent$line\n";
              }
              if ($i != $#lines) {
                  $value .= "\n";
              }
          }
      }
      else {
          $value =~ s/([$escape_re"\\])/$to_escape{ $1 } || sprintf '\\u%04x', ord($1)/eg;
          $value = '"' . $value . '"';
      }
  
      DEBUG and warn __PACKAGE__.':'.__LINE__.": (@$stack)\n";
      my $yaml = '';
      my $pvalue = $props;
      if ($props and length $value) {
          $pvalue .= " $value";
      }
      elsif (length $value) {
          $pvalue .= $value;
      }
      my $multiline = ($style == YAML_LITERAL_SCALAR_STYLE or $style == YAML_FOLDED_SCALAR_STYLE);
      my $newline = 0;
      if ($flow) {
          $indent = 0;
          if ($props and not length $value) {
              $pvalue .= ' ';
          }
          if ($last->{type} eq 'SEQ') {
              if ($last->{index} == 0) {
                  if ($self->column) {
                      $yaml .= ' ';
                  }
                  $yaml .= "[";
              }
              else {
                  $yaml .= ", ";
              }
          }
          elsif ($last->{type} eq 'MAP') {
              if ($last->{index} == 0) {
                  if ($self->column) {
                      $yaml .= ' ';
                  }
                  $yaml .= "{";
              }
              else {
                  $yaml .= ", ";
              }
              $last->{type} = 'MAPVALUE';
          }
          elsif ($last->{type} eq 'MAPVALUE') {

scripts/dex  view on Meta::CPAN

        'return' => 1
      },
      'QUOTED' => {
        'match' => 'cb_flowkey_quoted',
        'return' => 1
      },
      'QUOTED_MULTILINE' => {
        'match' => 'cb_quoted_multiline',
        'return' => 1
      }
    },
    'FLOWSEQ' => {
      'ALIAS' => {
        'match' => 'cb_send_flow_alias',
        'new' => 'FLOWSEQ_NEXT'
      },
      'FLOWMAP_START' => {
        'match' => 'cb_start_flowmap',
        'new' => 'NEWFLOWMAP'
      },
      'FLOWSEQ_START' => {
        'match' => 'cb_start_flowseq',
        'new' => 'NEWFLOWSEQ'
      },
      'PLAIN' => {
        'match' => 'cb_flow_plain',
        'new' => 'FLOWSEQ_NEXT'
      },
      'PLAIN_MULTI' => {
        'match' => 'cb_send_plain_multi',
        'new' => 'FLOWSEQ_NEXT'
      },
      'QUOTED' => {
        'match' => 'cb_flowkey_quoted',
        'new' => 'FLOWSEQ_NEXT'
      },
      'QUOTED_MULTILINE' => {
        'match' => 'cb_quoted_multiline',
        'new' => 'FLOWSEQ_NEXT'
      }
    },
    'FLOWSEQ_NEXT' => {
      'EOL' => {
        'new' => 'FLOWSEQ_NEXT'
      },
      'FLOWSEQ_END' => {
        'match' => 'cb_end_flowseq',
        'return' => 1
      },
      'FLOW_COMMA' => {
        'match' => 'cb_flow_comma',
        'return' => 1
      },
      'WS' => {
        'new' => 'FLOWSEQ_NEXT'
      }
    },
    'FULLMAPVALUE_INLINE' => {
      'ANCHOR' => {
        'EOL' => {
          'match' => 'cb_property_eol',
          'new' => 'FULLNODE_ANCHOR'
        },
        'WS' => {
          'DEFAULT' => {
            'new' => 'NODETYPE_MAPVALUE_INLINE'
          },
          'TAG' => {
            'EOL' => {
              'match' => 'cb_property_eol',
              'new' => 'FULLNODE_TAG_ANCHOR'
            },
            'WS' => {
              'new' => 'NODETYPE_MAPVALUE_INLINE'
            },
            'match' => 'cb_tag'
          }
        },
        'match' => 'cb_anchor'
      },
      'DEFAULT' => {
        'new' => 'NODETYPE_MAPVALUE_INLINE'
      },
      'TAG' => {
        'EOL' => {
          'match' => 'cb_property_eol',
          'new' => 'FULLNODE_TAG'
        },
        'WS' => {
          'ANCHOR' => {
            'EOL' => {
              'match' => 'cb_property_eol',
              'new' => 'FULLNODE_TAG_ANCHOR'
            },
            'WS' => {
              'new' => 'NODETYPE_MAPVALUE_INLINE'
            },
            'match' => 'cb_anchor'
          },
          'DEFAULT' => {
            'new' => 'NODETYPE_MAPVALUE_INLINE'
          }
        },
        'match' => 'cb_tag'
      }
    },
    'FULLNODE' => {
      'ANCHOR' => {
        'EOL' => {
          'match' => 'cb_property_eol',
          'new' => 'FULLNODE_ANCHOR'
        },
        'WS' => {
          'DEFAULT' => {
            'new' => 'NODETYPE_SCALAR_OR_MAP'
          },
          'TAG' => {
            'EOL' => {
              'match' => 'cb_property_eol',
              'new' => 'FULLNODE_TAG_ANCHOR'
            },
            'WS' => {
              'new' => 'NODETYPE_SCALAR_OR_MAP'
            },
            'match' => 'cb_tag'
          }
        },
        'match' => 'cb_anchor'
      },
      'DEFAULT' => {
        'new' => 'NODETYPE_NODE'
      },
      'EOL' => {
        'new' => 'FULLNODE'
      },
      'TAG' => {
        'EOL' => {
          'match' => 'cb_property_eol',
          'new' => 'FULLNODE_TAG'
        },
        'WS' => {
          'ANCHOR' => {
            'EOL' => {
              'match' => 'cb_property_eol',
              'new' => 'FULLNODE_TAG_ANCHOR'
            },
            'WS' => {
              'new' => 'NODETYPE_SCALAR_OR_MAP'
            },
            'match' => 'cb_anchor'
          },
          'DEFAULT' => {
            'new' => 'NODETYPE_SCALAR_OR_MAP'
          }
        },
        'match' => 'cb_tag'
      }
    },
    'FULLNODE_ANCHOR' => {
      'ANCHOR' => {
        'WS' => {
          'DEFAULT' => {
            'new' => 'NODETYPE_SCALAR_OR_MAP'
          },
          'TAG' => {
            'WS' => {
              'new' => 'NODETYPE_SCALAR_OR_MAP'
            },
            'match' => 'cb_tag'
          }
        },
        'match' => 'cb_anchor'
      },
      'DEFAULT' => {
        'new' => 'NODETYPE_NODE'
      },
      'EOL' => {
        'new' => 'FULLNODE_ANCHOR'
      },
      'TAG' => {
        'EOL' => {
          'match' => 'cb_property_eol',
          'new' => 'FULLNODE_TAG_ANCHOR'
        },
        'WS' => {
          'ANCHOR' => {
            'WS' => {
              'new' => 'NODETYPE_SCALAR_OR_MAP'
            },
            'match' => 'cb_anchor'
          },
          'DEFAULT' => {
            'new' => 'NODETYPE_SCALAR_OR_MAP'
          }
        },
        'match' => 'cb_tag'
      }
    },
    'FULLNODE_TAG' => {
      'ANCHOR' => {
        'EOL' => {
          'match' => 'cb_property_eol',
          'new' => 'FULLNODE_TAG_ANCHOR'
        },
        'WS' => {
          'DEFAULT' => {
            'new' => 'NODETYPE_SCALAR_OR_MAP'
          },
          'TAG' => {
            'WS' => {
              'new' => 'NODETYPE_SCALAR_OR_MAP'
            },
            'match' => 'cb_tag'
          }
        },
        'match' => 'cb_anchor'
      },
      'DEFAULT' => {
        'new' => 'NODETYPE_NODE'
      },
      'EOL' => {
        'new' => 'FULLNODE_TAG'
      },
      'TAG' => {
        'WS' => {
          'ANCHOR' => {
            'WS' => {
              'new' => 'NODETYPE_SCALAR_OR_MAP'
            },
            'match' => 'cb_anchor'
          },
          'DEFAULT' => {
            'new' => 'NODETYPE_SCALAR_OR_MAP'
          }
        },
        'match' => 'cb_tag'
      }
    },
    'FULLNODE_TAG_ANCHOR' => {
      'ANCHOR' => {
        'WS' => {
          'DEFAULT' => {
            'new' => 'NODETYPE_SCALAR_OR_MAP'
          },
          'TAG' => {
            'WS' => {
              'new' => 'NODETYPE_SCALAR_OR_MAP'
            },
            'match' => 'cb_tag'
          }
        },
        'match' => 'cb_anchor'
      },
      'DEFAULT' => {
        'new' => 'NODETYPE_NODE'
      },
      'EOL' => {
        'new' => 'FULLNODE_TAG_ANCHOR'
      },
      'TAG' => {
        'WS' => {
          'ANCHOR' => {

scripts/dex  view on Meta::CPAN

              WS: { new: FULLMAPVALUE_INLINE }
          COLON:
            match: cb_send_mapkey
            EOL: { new: FULLNODE }
            WS: { new: FULLMAPVALUE_INLINE }
      
        COLON:
          match: cb_empty_mapkey
          EOL: { new: FULLNODE }
          WS: { new: FULLMAPVALUE_INLINE }
      
        DOC_END:
          match: cb_end_document
          EOL: { }
      
        DOC_START:
          match: cb_end_doc_start_document
          EOL: { new: FULLNODE }
          WS: { new: FULLNODE }
      
        EOL:
          new: RULE_MAPKEY
      
      
      NODETYPE_SEQ:
        DASH:
          match: cb_seqitem
          EOL: { new: FULLNODE }
          WS: { new: FULLNODE }
        DOC_END:
          match: cb_end_document
          EOL: { }
        DOC_START:
          match: cb_end_doc_start_document
          EOL: { new: FULLNODE }
          WS: { new: FULLNODE }
      
        EOL:
          new: NODETYPE_SEQ
      
      NODETYPE_MAP:
        ANCHOR:
          match: cb_anchor
          WS:
            TAG:
              match: cb_tag
              WS: { new: RULE_MAPKEY  }
            DEFAULT: { new: RULE_MAPKEY }
        TAG:
          match: cb_tag
          WS:
            ANCHOR:
              match: cb_anchor
              WS: { new: RULE_MAPKEY  }
            DEFAULT: { new: RULE_MAPKEY }
        DEFAULT: { new: RULE_MAPKEY }
      
      FULLNODE_ANCHOR:
        TAG:
          match: cb_tag
          EOL: { match: cb_property_eol, new: FULLNODE_TAG_ANCHOR }
          WS:
            ANCHOR:
              match: cb_anchor
              WS: { new: NODETYPE_SCALAR_OR_MAP  }
            DEFAULT: { new: NODETYPE_SCALAR_OR_MAP }
        ANCHOR:
          match: cb_anchor
          WS:
            TAG:
              match: cb_tag
              WS: { new: NODETYPE_SCALAR_OR_MAP  }
            DEFAULT: { new: NODETYPE_SCALAR_OR_MAP }
        EOL: { new: FULLNODE_ANCHOR }
        DEFAULT: { new: NODETYPE_NODE }
      
      FULLNODE_TAG:
        ANCHOR:
          match: cb_anchor
          EOL: { match: cb_property_eol, new: FULLNODE_TAG_ANCHOR }
          WS:
            TAG:
              match: cb_tag
              WS: { new: NODETYPE_SCALAR_OR_MAP  }
            DEFAULT: { new: NODETYPE_SCALAR_OR_MAP, }
        TAG:
          match: cb_tag
          WS:
            ANCHOR:
              match: cb_anchor
              WS: { new: NODETYPE_SCALAR_OR_MAP  }
            DEFAULT: { new: NODETYPE_SCALAR_OR_MAP }
        EOL: { new: FULLNODE_TAG }
        DEFAULT: { new: NODETYPE_NODE }
      
      FULLNODE_TAG_ANCHOR:
        ANCHOR:
          match: cb_anchor
          WS:
            TAG:
              match: cb_tag
              WS: { new: NODETYPE_SCALAR_OR_MAP  }
            DEFAULT: { new: NODETYPE_SCALAR_OR_MAP }
        TAG:
          match: cb_tag
          WS:
            ANCHOR:
              match: cb_anchor
              WS: { new: NODETYPE_SCALAR_OR_MAP  }
            DEFAULT: { new: NODETYPE_SCALAR_OR_MAP }
        EOL: { new: FULLNODE_TAG_ANCHOR }
        DEFAULT: { new: NODETYPE_NODE }
      
      FULLNODE:
        ANCHOR:
          match: cb_anchor
          EOL: { match: cb_property_eol, new: FULLNODE_ANCHOR }
          WS:
            TAG:
              match: cb_tag
              EOL: { match: cb_property_eol, new: FULLNODE_TAG_ANCHOR }
              WS: { new: NODETYPE_SCALAR_OR_MAP  }
            DEFAULT: { new: NODETYPE_SCALAR_OR_MAP }
        TAG:
          match: cb_tag
          EOL: { match: cb_property_eol, new: FULLNODE_TAG }
          WS:
            ANCHOR:
              match: cb_anchor
              EOL: { match: cb_property_eol, new: FULLNODE_TAG_ANCHOR }
              WS: { new: NODETYPE_SCALAR_OR_MAP  }
            DEFAULT: { new: NODETYPE_SCALAR_OR_MAP }
        EOL: { new: FULLNODE }
        DEFAULT: { new: NODETYPE_NODE }
      
      FULLMAPVALUE_INLINE:
        ANCHOR:
          match: cb_anchor
          EOL: { match: cb_property_eol, new: FULLNODE_ANCHOR }
          WS:
            TAG:
              match: cb_tag
              EOL: { match: cb_property_eol, new: FULLNODE_TAG_ANCHOR }
              WS: { new: NODETYPE_MAPVALUE_INLINE  }
            DEFAULT: { new: NODETYPE_MAPVALUE_INLINE }
        TAG:
          match: cb_tag
          EOL: { match: cb_property_eol, new: FULLNODE_TAG }
          WS:
            ANCHOR:
              match: cb_anchor
              EOL: { match: cb_property_eol, new: FULLNODE_TAG_ANCHOR }
              WS: { new: NODETYPE_MAPVALUE_INLINE  }
            DEFAULT: { new: NODETYPE_MAPVALUE_INLINE }
        DEFAULT: { new: NODETYPE_MAPVALUE_INLINE }
      
      
      NODETYPE_MAPVALUE_INLINE:
        ALIAS:
          match: cb_send_alias
          EOL: { }
      
        QUOTED:
          match: cb_take_quoted
          EOL: { match: cb_send_scalar }
      
        QUOTED_MULTILINE:
          match: cb_quoted_multiline
          EOL: { }
      
        PLAIN:
          match: cb_start_plain
          EOL:
            match: cb_send_scalar
      
        PLAIN_MULTI:
          match: cb_send_plain_multi
          EOL: { }
      
        BLOCK_SCALAR:
          match: cb_send_block_scalar
          EOL: { }
      
        FLOWSEQ_START:
          match: cb_start_flowseq
          new: NEWFLOWSEQ
      
        FLOWMAP_START:
          match: cb_start_flowmap
          new: NEWFLOWMAP
      
        DOC_END:
          match: cb_end_document
          EOL: { }
      
      
      DOCUMENT_END:
        DOC_END:
          match: cb_end_document
          EOL: { }
        DOC_START:
          match: cb_end_doc_start_document
          EOL: { new: FULLNODE }
          WS: { new: FULLNODE }
      
        EOL:
          new: DOCUMENT_END
      
      
      STREAM:
      
        DOC_END:

scripts/dex  view on Meta::CPAN

      FLOW_COMMA => [qw/ bold magenta /],
      PLAINKEY => [qw/ bright_blue /],
  );
  
  sub ansicolored {
      my ($class, $tokens, %args) = @_;
      my $expand_tabs = $args{expand_tabs};
      $expand_tabs = 1 unless defined $expand_tabs;
      require Term::ANSIColor;
  
      local $Term::ANSIColor::EACHLINE = "\n";
      my $ansi = '';
      my $highlighted = '';
  
      my @list = $class->transform($tokens);
  
  
      for my $token (@list) {
          my $name = $token->{name};
          my $str = $token->{value};
  
          my $color = $ansicolors{ $name };
          if ($color) {
              $str = Term::ANSIColor::colored($color, $str);
          }
          $highlighted .= $str;
      }
  
      if ($expand_tabs) {
          # Tabs can't be displayed with ansicolors
          $highlighted =~ s/\t/' ' x 8/eg;
      }
      $ansi .= $highlighted;
      return $ansi;
  }
  
  my %htmlcolors = (
      ANCHOR => 'anchor',
      ALIAS => 'alias',
      SINGLEQUOTE => 'singlequote',
      DOUBLEQUOTE => 'doublequote',
      SINGLEQUOTED => 'singlequoted',
      DOUBLEQUOTED => 'doublequoted',
      SINGLEQUOTED_LINE => 'singlequoted',
      DOUBLEQUOTED_LINE => 'doublequoted',
      INDENT => 'indent',
      DASH => 'dash',
      COLON => 'colon',
      QUESTION => 'question',
      YAML_DIRECTIVE => 'yaml_directive',
      TAG_DIRECTIVE => 'tag_directive',
      TAG => 'tag',
      COMMENT => 'comment',
      LITERAL => 'literal',
      FOLDED => 'folded',
      DOC_START => 'doc_start',
      DOC_END => 'doc_end',
      BLOCK_SCALAR_CONTENT => 'block_scalar_content',
      TAB => 'tab',
      ERROR => 'error',
      EOL => 'eol',
      TRAILING_SPACE => 'trailing_space',
      FLOWSEQ_START => 'flowseq_start',
      FLOWSEQ_END => 'flowseq_end',
      FLOWMAP_START => 'flowmap_start',
      FLOWMAP_END => 'flowmap_end',
      FLOW_COMMA => 'flow_comma',
      PLAINKEY => 'plainkey',
  );
  sub htmlcolored {
      require HTML::Entities;
      my ($class, $tokens) = @_;
      my $html = '';
      my @list = $class->transform($tokens);
      for my $token (@list) {
          my $name = $token->{name};
          my $str = $token->{value};
          my $colorclass = $htmlcolors{ $name } || 'default';
          $str = HTML::Entities::encode_entities($str);
          $html .= qq{<span class="$colorclass">$str</span>};
      }
      return $html;
  }
  
  sub transform {
      my ($class, $tokens) = @_;
      my @list;
      for my $token (@$tokens) {
          my @values;
          my $value = $token->{value};
          my $subtokens = $token->{subtokens};
          if ($subtokens) {
              @values = @$subtokens;
          }
          else {
              @values = $token;
          }
          for my $token (@values) {
              my $value = defined $token->{orig} ? $token->{orig} : $token->{value};
              push @list, map {
                      $_ =~ tr/\t/\t/
                      ? { name => 'TAB', value => $_ }
                      : { name => $token->{name}, value => $_ }
                  } split m/(\t+)/, $value;
          }
      }
      for my $i (0 .. $#list) {
          my $token = $list[ $i ];
          my $name = $token->{name};
          my $str = $token->{value};
          my $trailing_space = 0;
          if ($token->{name} eq 'EOL') {
              if ($str =~ m/ +([\r\n]|\z)/) {
                  $token->{name} = "TRAILING_SPACE";
              }
          }
          elsif ($i < $#list) {
              if ($name eq 'PLAIN') {
                  for my $n ($i+1 .. $#list) {
                      my $next = $list[ $n ];
                      last if $next->{name} eq 'EOL';

scripts/dex  view on Meta::CPAN

      my $next_line = $self->fetch_next_line;
      if (not $next_line) {
          return [];
      }
  
      my $spaces = $next_line->[0];
      my $yaml = \$next_line->[1];
      if (not length $$yaml) {
          $self->push_tokens([ EOL => join('', @$next_line), $self->line ]);
          $self->set_next_line(undef);
          return $next;
      }
      if (substr($$yaml, 0, 1) eq '#') {
          $self->push_tokens([ EOL => join('', @$next_line), $self->line ]);
          $self->set_next_line(undef);
          return $next;
      }
      if (not $spaces and substr($$yaml, 0, 1) eq "%") {
          $self->_fetch_next_tokens_directive($yaml, $next_line->[2]);
          $self->set_context(0);
          $self->set_next_line(undef);
          return $next;
      }
      if (not $spaces and $$yaml =~ s/\A(---|\.\.\.)(?=$RE_WS|\z)//) {
          $self->push_tokens([ $TOKEN_NAMES{ $1 } => $1, $self->line ]);
      }
      else {
          $self->push_tokens([ SPACE => $spaces, $self->line ]);
      }
  
      my $partial = $self->_fetch_next_tokens($next_line);
      unless ($partial) {
          $self->set_next_line(undef);
      }
      return $next;
  }
  
  my %ANCHOR_ALIAS_TAG =    ( '&' => 1, '*' => 1, '!' => 1 );
  my %BLOCK_SCALAR =        ( '|' => 1, '>' => 1 );
  my %COLON_DASH_QUESTION = ( ':' => 1, '-' => 1, '?' => 1 );
  my %QUOTED =              ( '"' => 1, "'" => 1 );
  my %FLOW =                ( '{' => 1, '[' => 1, '}' => 1, ']' => 1, ',' => 1 );
  my %CONTEXT =             ( '"' => 1, "'" => 1, '>' => 1, '|' => 1 );
  
  my $RE_ESCAPES = qr{(?:
      \\([ \\\/_0abefnrtvLNP"]) | \\x([0-9a-fA-F]{2})
      | \\u([A-Fa-f0-9]{4}) | \\U([A-Fa-f0-9]{4,8})
  )}x;
  my %CONTROL = (
      '\\' => '\\', '/' => '/', n => "\n", t => "\t", r => "\r", b => "\b",
      'a' => "\a", 'b' => "\b", 'e' => "\e", 'f' => "\f", 'v' => "\x0b",
      'P' => "\x{2029}", L => "\x{2028}", 'N' => "\x85",
      '0' => "\0", '_' => "\xa0", ' ' => ' ', q/"/ => q/"/,
  );
  
  sub _fetch_next_tokens {
      TRACE and warn __PACKAGE__.':'.__LINE__.": _fetch_next_tokens\n";
      my ($self, $next_line) = @_;
  
      my $yaml = \$next_line->[1];
      my $eol = $next_line->[2];
  
      my @tokens;
  
      while (1) {
          unless (length $$yaml) {
              push @tokens, ( EOL => $eol, $self->line );
              $self->push_tokens(\@tokens);
              return;
          }
          my $first = substr($$yaml, 0, 1);
          my $plain = 0;
  
          if ($self->context) {
              if ($$yaml =~ s/\A($RE_WS*)://) {
                  push @tokens, ( WS => $1, $self->line ) if $1;
                  push @tokens, ( COLON => ':', $self->line );
                  $self->set_context(0);
                  next;
              }
              if ($$yaml =~ s/\A($RE_WS*(?: #.*))\z//) {
                  push @tokens, ( EOL => $1 . $eol, $self->line );
                  $self->push_tokens(\@tokens);
                  return;
              }
              $self->set_context(0);
          }
          if ($CONTEXT{ $first }) {
              push @tokens, ( CONTEXT => $first, $self->line );
              $self->push_tokens(\@tokens);
              return 1;
          }
          elsif ($COLON_DASH_QUESTION{ $first }) {
              my $token_name = $TOKEN_NAMES{ $first };
              if ($$yaml =~ s/\A\Q$first\E(?:($RE_WS+)|\z)//) {
                  my $token_name = $TOKEN_NAMES{ $first };
                  push @tokens, ( $token_name => $first, $self->line );
                  if (not defined $1) {
                      push @tokens, ( EOL => $eol, $self->line );
                      $self->push_tokens(\@tokens);
                      return;
                  }
                  my $ws = $1;
                  if ($$yaml =~ s/\A(#.*|)\z//) {
                      push @tokens, ( EOL => $ws . $1 . $eol, $self->line );
                      $self->push_tokens(\@tokens);
                      return;
                  }
                  push @tokens, ( WS => $ws, $self->line );
                  next;
              }
              elsif ($self->flowcontext and $$yaml =~ s/\A:(?=[,\{\}\[\]])//) {
                  push @tokens, ( $token_name => $first, $self->line );
                  next;
              }
              $plain = 1;
          }
          elsif ($ANCHOR_ALIAS_TAG{ $first }) {
              my $token_name = $TOKEN_NAMES{ $first };
              my $REGEX = $REGEXES{ $token_name };
              if ($$yaml =~ s/\A$REGEX//) {
                  push @tokens, ( $token_name => $1, $self->line );
              }
              else {
                  push @tokens, ( "Invalid $token_name" => $$yaml, $self->line );
                  $self->push_tokens(\@tokens);
                  return;
              }
          }
          elsif ($first eq ' ' or $first eq "\t") {
              if ($$yaml =~ s/\A($RE_WS+)//) {
                  my $ws = $1;
                  if ($$yaml =~ s/\A((?:#.*)?\z)//) {
                      push @tokens, ( EOL => $ws . $1 . $eol, $self->line );
                      $self->push_tokens(\@tokens);
                      return;
                  }
                  push @tokens, ( WS => $ws, $self->line );
              }
          }
          elsif ($FLOW{ $first }) {
              push @tokens, ( $TOKEN_NAMES{ $first } => $first, $self->line );
              substr($$yaml, 0, 1, '');
              my $flowcontext = $self->flowcontext;
              if ($first eq '{' or $first eq '[') {
                  $self->set_flowcontext(++$flowcontext);
              }
              elsif ($first eq '}' or $first eq ']') {
                  $self->set_flowcontext(--$flowcontext);
              }
          }
          else {
              $plain = 1;
          }
  
          if ($plain) {
              push @tokens, ( CONTEXT => '', $self->line );
              $self->push_tokens(\@tokens);
              return 1;
          }
  
      }
  
      return;
  }
  
  sub fetch_plain {
      my ($self, $indent, $context) = @_;
      my $next_line = $self->next_line;
      my $yaml = \$next_line->[1];
      my $eol = $next_line->[2];
      my $REGEX = $RE_PLAIN_WORDS;
      if ($self->flowcontext) {
          $REGEX = $RE_PLAIN_WORDS_FLOW;
      }
  
      my @tokens;
      unless ($$yaml =~ s/\A($REGEX)//) {
          $self->push_tokens(\@tokens);
          $self->exception("Invalid plain scalar");
      }
      my $plain = $1;
      push @tokens, ( PLAIN => $plain, $self->line );
  
      if ($$yaml =~ s/\A(?:($RE_WS+#.*)|($RE_WS*))\z//) {
          if (defined $1) {
              push @tokens, ( EOL => $1 . $eol, $self->line );
              $self->push_tokens(\@tokens);
              $self->set_next_line(undef);
              return;
          }
          else {
              push @tokens, ( EOL => $2. $eol, $self->line );
              $self->set_next_line(undef);
          }
      }
      else {
          $self->push_tokens(\@tokens);
          my $partial = $self->_fetch_next_tokens($next_line);
          if (not $partial) {
              $self->set_next_line(undef);
          }
          return;
      }
  
      my $RE2 = $RE_PLAIN_WORDS2;
      if ($self->flowcontext) {
          $RE2 = $RE_PLAIN_WORDS_FLOW2;
      }
      my $fetch_next = 0;
      my @lines = ($plain);
      my @next;
      LOOP: while (1) {
          $next_line = $self->fetch_next_line;
          if (not $next_line) {
              last LOOP;
          }
          my $spaces = $next_line->[0];
          my $yaml = \$next_line->[1];
          my $eol = $next_line->[2];
  
          if (not length $$yaml) {
              push @tokens, ( EOL => $spaces . $eol, $self->line );
              $self->set_next_line(undef);
              push @lines, '';
              next LOOP;
          }
  
          if (not $spaces and $$yaml =~ s/\A(---|\.\.\.)(?=$RE_WS|\z)//) {
              push @next, $TOKEN_NAMES{ $1 } => $1, $self->line;
              $fetch_next = 1;
              last LOOP;
          }
          if ((length $spaces) < $indent) {
              last LOOP;
          }
  
          my $ws = '';
          if ($$yaml =~ s/\A($RE_WS+)//) {
              $ws = $1;
          }
          if (not length $$yaml) {
              push @tokens, ( EOL => $spaces . $ws . $eol, $self->line );
              $self->set_next_line(undef);
              push @lines, '';
              next LOOP;
          }
          if ($$yaml =~ s/\A(#.*)\z//) {
              push @tokens, ( EOL => $spaces . $ws . $1 . $eol, $self->line );
              $self->set_next_line(undef);
              last LOOP;
          }
  
          if ($$yaml =~ s/\A($RE2)//) {
              push @tokens, INDENT => $spaces, $self->line;
              push @tokens, WS => $ws, $self->line;
              push @tokens, PLAIN => $1, $self->line;
              push @lines, $1;
              my $ws = '';
              if ($$yaml =~ s/\A($RE_WS+)//) {
                  $ws = $1;
              }
              if (not length $$yaml) {
                  push @tokens, EOL => $ws . $eol, $self->line;
                  $self->set_next_line(undef);
                  next LOOP;
              }
  
              if ($$yaml =~ s/\A(#.*)\z//) {
                  push @tokens, EOL => $ws . $1 . $eol, $self->line;
                  $self->set_next_line(undef);
                  last LOOP;
              }
              else {
                  push @tokens, WS => $ws, $self->line if $ws;
                  $fetch_next = 1;
              }
          }
          else {
              push @tokens, SPACE => $spaces, $self->line;
              push @tokens, WS => $ws, $self->line;
              if ($self->flowcontext) {
                  $fetch_next = 1;
              }
              else {
                  push @tokens, ERROR => $$yaml, $self->line;
              }
          }
  
          last LOOP;
  
      }
      # remove empty lines at the end
      while (@lines > 1 and $lines[-1] eq '') {
          pop @lines;
      }
      if (@lines > 1) {
          my $value = YAML::PP::Render->render_multi_val(\@lines);
          my @eol;
          if ($tokens[-3] eq 'EOL') {
              @eol = splice @tokens, -3;
          }
          $self->push_subtokens( { name => 'PLAIN_MULTI', value => $value }, \@tokens);
          $self->push_tokens([ @eol, @next ]);
      }
      else {
          $self->push_tokens([ @tokens, @next ]);
      }
      @tokens = ();
      if ($fetch_next) {
          my $partial = $self->_fetch_next_tokens($next_line);
          if (not $partial) {
              $self->set_next_line(undef);
          }
      }
      return;
  }
  
  sub fetch_block {
      my ($self, $indent, $context) = @_;
      my $next_line = $self->next_line;
      my $yaml = \$next_line->[1];
      my $eol = $next_line->[2];
  
      my @tokens;
      my $token_name = $TOKEN_NAMES{ $context };
      $$yaml =~ s/\A\Q$context\E// or die "Unexpected";
      push @tokens, ( $token_name => $context, $self->line );
      my $current_indent = $indent;
      my $started = 0;
      my $set_indent = 0;
      my $chomp = '';
      if ($$yaml =~ s/\A([1-9]\d*)([+-]?)//) {
          push @tokens, ( BLOCK_SCALAR_INDENT => $1, $self->line );
          $set_indent = $1;
          $chomp = $2 if $2;
          push @tokens, ( BLOCK_SCALAR_CHOMP => $2, $self->line ) if $2;
      }
      elsif ($$yaml =~ s/\A([+-])([1-9]\d*)?//) {
          push @tokens, ( BLOCK_SCALAR_CHOMP => $1, $self->line );
          $chomp = $1;
          push @tokens, ( BLOCK_SCALAR_INDENT => $2, $self->line ) if $2;
          $set_indent = $2 if $2;
      }
      if ($set_indent) {
          $started = 1;
          $current_indent = $set_indent;
      }
      if (not length $$yaml) {
          push @tokens, ( EOL => $eol, $self->line );
      }
      elsif ($$yaml =~ s/\A($RE_WS*(?:$RE_WS#.*|))\z//) {
          push @tokens, ( EOL => $1 . $eol, $self->line );
      }
      else {
          $self->push_tokens(\@tokens);
          $self->exception("Invalid block scalar");
      }
  
      my @lines;
      while (1) {
          $self->set_next_line(undef);
          $next_line = $self->fetch_next_line;
          if (not $next_line) {
              last;
          }
          my $spaces = $next_line->[0];
          my $content = $next_line->[1];
          my $eol = $next_line->[2];
          if (not $spaces and $content =~ m/\A(---|\.\.\.)(?=$RE_WS|\z)/) {
              last;
          }
          if ((length $spaces) < $current_indent) {
              if (length $content) {
                  last;
              }
              else {
                  push @lines, '';
                  push @tokens, ( EOL => $spaces . $eol, $self->line );
                  next;
              }
          }
          if ((length $spaces) > $current_indent) {
              if ($started) {
                  ($spaces, my $more_spaces) = unpack "a${current_indent}a*", $spaces;
                  $content = $more_spaces . $content;
              }
          }
          unless (length $content) {
              push @lines, '';
              push @tokens, ( INDENT => $spaces, $self->line, EOL => $eol, $self->line );
              unless ($started) {
                  $current_indent = length $spaces;
              }
              next;
          }
          unless ($started) {
              $started = 1;
              $current_indent = length $spaces;
          }
          push @lines, $content;
          push @tokens, (
              INDENT => $spaces, $self->line,
              BLOCK_SCALAR_CONTENT => $content, $self->line,
              EOL => $eol, $self->line,
          );
      }
      my $value = YAML::PP::Render->render_block_scalar($context, $chomp, \@lines);
      my @eol = splice @tokens, -3;
      $self->push_subtokens( { name => 'BLOCK_SCALAR', value => $value }, \@tokens );
      $self->push_tokens([ @eol ]);
      return 0;
  }
  
  sub fetch_quoted {
      my ($self, $indent, $context) = @_;
      my $next_line = $self->next_line;
      my $yaml = \$next_line->[1];
      my $spaces = $next_line->[0];
  
      my $token_name = $TOKEN_NAMES{ $context };
      $$yaml =~ s/\A\Q$context// or die "Unexpected";;
      my @tokens = ( $token_name => $context, $self->line );
  
      my $start = 1;
      my @values;
      while (1) {
  
          unless ($start) {
              $next_line = $self->fetch_next_line or do {
                      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("Missing closing quote <$context> at EOF");
                  };
              $start = 0;
              $spaces = $next_line->[0];
              $yaml = \$next_line->[1];
  
              if (not length $$yaml) {
                  push @tokens, ( EOL => $spaces . $next_line->[2], $self->line );
                  $self->set_next_line(undef);
                  push @values, { value => '', orig => '' };
                  next;
              }
              elsif (not $spaces and $$yaml =~ m/\A(---|\.\.\.)(?=$RE_WS|\z)/) {
                      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("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 );
      }
      else {
          push @tokens, ( 'Invalid directive' => $$yaml, $self->line );
          push @tokens, ( EOL => $eol, $self->line );
      }
      $self->push_tokens(\@tokens);
      return;
  }
  
  sub push_tokens {
      my ($self, $new_tokens) = @_;
      my $next = $self->next_tokens;
      my $line = $self->line;
      my $column = $self->offset;
  
      for (my $i = 0; $i < @$new_tokens; $i += 3) {
          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;

scripts/dex  view on Meta::CPAN

      my $tokens = $self->tokens;
      my $next_tokens = $self->lexer->next_tokens;
  
      unless ($self->lex_next_tokens) {
          $self->end_document(1);
          return 0;
      }
      unless ($self->new_node) {
          if ($self->level > 0) {
              my $new_rule = $nodetypes{ $event_types->[-1] }
                  or die "Did not find '$event_types->[-1]'";
              $self->set_rule( $new_rule );
          }
      }
  
      my $rule_name = $self->rule;
      DEBUG and $self->info("----------------> parse_tokens($rule_name)");
      my $rule = $GRAMMAR->{ $rule_name }
          or die "Could not find rule $rule_name";
  
      TRACE and $self->debug_rules($rule);
      TRACE and $self->debug_yaml;
      DEBUG and $self->debug_next_line;
  
      RULE: while ($rule_name) {
          DEBUG and $self->info("RULE: $rule_name");
          TRACE and $self->debug_tokens($next_tokens);
  
          unless (@$next_tokens) {
              $self->exception("No more tokens");
          }
          TRACE and warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$next_tokens->[0]], ['next_token']);
          my $got = $next_tokens->[0]->{name};
          if ($got eq 'CONTEXT') {
              my $context = shift @$next_tokens;
              my $indent = $offsets->[-1];
              $indent++ unless $self->lexer->flowcontext;
              my $method = $fetch_method{ $context->{value} };
              my $partial = $self->lexer->$method($indent, $context->{value});
              next RULE;
          }
          my $def = $rule->{ $got };
          if ($def) {
              push @$tokens, shift @$next_tokens;
          }
          elsif ($def = $rule->{DEFAULT}) {
              $got = 'DEFAULT';
          }
          else {
              $self->expected(
                  expected => [keys %$rule],
                  got => $next_tokens->[0],
              );
          }
  
          DEBUG and $self->got("---got $got");
          if (my $sub = $def->{match}) {
              DEBUG and $self->info("CALLBACK $sub");
              $self->$sub(@$tokens ? $tokens->[-1] : ());
          }
          my $eol = $got eq 'EOL';
          my $new = $def->{new};
          if ($new) {
              DEBUG and $self->got("NEW: $new");
              $rule_name = $new;
              $self->set_rule($rule_name);
          }
          elsif ($eol) {
          }
          elsif ($def->{return}) {
              $rule_name = $nodetypes{ $event_types->[-1] }
                  or die "Unexpected event type $event_types->[-1]";
              $self->set_rule($rule_name);
          }
          else {
              $rule_name .= " - $got"; # for debugging
              $rule = $def;
              next RULE;
          }
          if ($eol) {
              unless ($self->lex_next_tokens) {
                  $self->end_document(1);
                  return 0;
              }
              unless ($self->new_node) {
                  if ($self->level > 0) {
                      $rule_name = $nodetypes{ $event_types->[-1] }
                          or die "Did not find '$event_types->[-1]'";
                      $self->set_rule( $rule_name );
                  }
              }
              $rule_name = $self->rule;
          }
          $rule = $GRAMMAR->{ $rule_name }
              or die "Unexpected rule $rule_name";
  
      }
  
      die "Unexpected";
  }
  
  sub end_sequence {
      my ($self) = @_;
      my $event_types = $self->events;
      pop @{ $event_types };
      pop @{ $self->offset };
      my $info = { name => 'sequence_end_event' };
      $self->callback->($self, $info->{name} => $info );
      $event_types->[-1] = $next_event{ $event_types->[-1] };
  }
  
  sub remove_nodes {
      my ($self, $space) = @_;
      my $offset = $self->offset;
      my $event_types = $self->events;
  
      my $exp = $event_types->[-1];
      while (@$offset) {
          if ($offset->[ -1 ] <= $space) {
              last;
          }
          if ($exp eq 'MAPVALUE') {
              $self->scalar_event({ style => YAML_PLAIN_SCALAR_STYLE, value => '' });
              $exp = 'MAP';
          }
          my $info = { name => $exp };
          $info->{name} = $event_to_method{ $exp } . '_end_event';
          pop @{ $event_types };
          pop @{ $offset };
          $self->callback->($self, $info->{name} => $info );
          $event_types->[-1] = $next_event{ $event_types->[-1] };
          $exp = $event_types->[-1];
      }
      return $exp;
  }
  
  sub start_stream {
      my ($self) = @_;
      push @{ $self->events }, 'STR';
      push @{ $self->offset }, -1;

scripts/dex  view on Meta::CPAN

      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];
      $last->{inline} ||= [];
      push @{ $last->{inline} }, {
          type => 'anchor',
          value => $anchor,
          offset => $token->{column},
      };
  }
  
  sub cb_property_eol {
      my ($self, $res) = @_;
      my $stack = $self->event_stack;
      my $last = $stack->[-1]->[1];
      my $inline = delete $last->{inline} or return;
      my $newline = $last->{newline} ||= [];
      push @$newline, @$inline;
  }
  
  sub cb_mapkey {
      my ($self, $token) = @_;
      my $stack = $self->event_stack;
      my $info = {
          style => YAML_PLAIN_SCALAR_STYLE,
          value => $token->{value},
          offset => $token->{column},
      };
      if (@$stack and $stack->[-1]->[0] eq 'properties') {
          $self->fetch_inline_properties($stack, $info);
      }
      push @{ $stack }, [ scalar => $info ];
  }
  
  sub cb_send_mapkey {
      my ($self, $res) = @_;
      my $last = pop @{ $self->event_stack };
      $self->scalar_event($last->[1]);
      $self->set_new_node(1);
  }
  
  sub cb_send_scalar {
      my ($self, $res) = @_;
      my $last = pop @{ $self->event_stack };
      $self->scalar_event($last->[1]);
  }
  
  sub cb_empty_mapkey {
      my ($self, $token) = @_;
      my $stack = $self->event_stack;
      my $info = {
          style => YAML_PLAIN_SCALAR_STYLE,
          value => '',
          offset => $token->{column},
      };
      if (@$stack and $stack->[-1]->[0] eq 'properties') {
          $self->fetch_inline_properties($stack, $info);
      }
      $self->scalar_event($info);
      $self->set_new_node(1);
  }
  
  sub cb_send_flow_alias {
      my ($self, $token) = @_;
      my $alias = substr($token->{value}, 1);
      $self->alias_event({ value => $alias });
  }
  
  sub cb_send_alias {
      my ($self, $token) = @_;
      my $alias = substr($token->{value}, 1);
      $self->alias_event({ value => $alias });



( run in 0.924 second using v1.01-cache-2.11-cpan-8f98c5d2c55 )