App-Dex

 view release on metacpan or  search on metacpan

scripts/dex  view on Meta::CPAN

      if (keys %args) {
          die "Unexpected arguments: " . join ', ', sort keys %args;
      }
      my $self = bless {
          representer => YAML::PP::Representer->new(
              schema => $schema,
              preserve => $preserve,
          ),
          version_directive => $version_directive,
          emitter => $emitter,
          seen => {},
          anchors => {},
          anchor_num => 0,
          header => $header,
          footer => $footer,
      }, $class;
      return $self;
  }
  
  sub clone {
      my ($self) = @_;
      my $clone = {
          representer => $self->representer->clone,
          emitter => $self->emitter->clone,
          version_directive => $self->version_directive,
          seen => {},
          anchors => {},
          anchor_num => 0,
          header => $self->header,
          footer => $self->footer,
      };
      return bless $clone, ref $self;
  }
  
  sub init {
      my ($self) = @_;
      $self->{seen} = {};
      $self->{anchors} = {};
      $self->{anchor_num} = 0;
  }
  
  sub emitter { return $_[0]->{emitter} }
  sub representer { return $_[0]->{representer} }
  sub set_representer { $_[0]->{representer} = $_[1] }
  sub header { return $_[0]->{header} }
  sub footer { return $_[0]->{footer} }
  sub version_directive { return $_[0]->{version_directive} }
  
  sub dump {
      my ($self, @docs) = @_;
      $self->emitter->init;
  
      $self->emitter->stream_start_event({});
  
      for my $i (0 .. $#docs) {
          my $header_implicit = ($i == 0 and not $self->header);
          my %args = (
              implicit => $header_implicit,
          );
          if ($self->version_directive) {
              my ($major, $minor) = split m/\./, $self->representer->schema->yaml_version;
              $args{version_directive} = { major => $major, minor => $minor };
          }
          $self->emitter->document_start_event( \%args );
          $self->init;
          $self->check_references($docs[ $i ]);
          $self->dump_node($docs[ $i ]);
          my $footer_implicit = (not $self->footer);
          $self->emitter->document_end_event({ implicit => $footer_implicit });
      }
  
      $self->emitter->stream_end_event({});
  
      my $output = $self->emitter->writer->output;
      $self->emitter->finish;
      return $output;
  }
  
  sub dump_node {
      my ($self, $value) = @_;
      my $node = {
          value => $value,
      };
      if (ref $value) {
  
          my $seen = $self->{seen};
          my $refaddr = refaddr $value;
          if ($seen->{ $refaddr } and $seen->{ $refaddr } > 1) {
              my $anchor = $self->{anchors}->{ $refaddr };
              unless (defined $anchor) {
                  if ($self->representer->preserve_alias) {
                      if (ref $node->{value} eq 'YAML::PP::Preserve::Scalar') {
                          if (defined $node->{value}->alias) {
                              $node->{anchor} = $node->{value}->alias;
                              $self->{anchors}->{ $refaddr } = $node->{value}->alias;
                          }
                      }
                      elsif (reftype $node->{value} eq 'HASH') {
                          if (my $tied = tied %{ $node->{value} } ) {
                              if (defined $tied->{alias}) {
                                  $node->{anchor} = $tied->{alias};
                                  $self->{anchors}->{ $refaddr } = $node->{anchor};
                              }
                          }
                      }
                      elsif (reftype $node->{value} eq 'ARRAY') {
                          if (my $tied = tied @{ $node->{value} } ) {
                              if (defined $tied->{alias}) {
                                  $node->{anchor} = $tied->{alias};
                                  $self->{anchors}->{ $refaddr } = $node->{anchor};
                              }
                          }
                      }
                  }
                  unless (defined $node->{anchor}) {
                      my $num = ++$self->{anchor_num};
                      $self->{anchors}->{ $refaddr } = $num;
                      $node->{anchor} = $num;
                  }
              }
              else {

scripts/dex  view on Meta::CPAN

      }
      elsif ($style == YAML_PLAIN_SCALAR_STYLE) {
          if (not length $value) {
          }
          elsif ($value =~ m/[$escape_re_without_lb]/) {
              $style = YAML_DOUBLE_QUOTED_SCALAR_STYLE;
          }
          elsif ($value eq "\n") {
              $style = YAML_DOUBLE_QUOTED_SCALAR_STYLE;
          }
          elsif ($value !~ tr/ //c) {
              $style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
          }
          elsif ($value !~ tr/ \n//c) {
              $style = YAML_DOUBLE_QUOTED_SCALAR_STYLE;
          }
          elsif ($value =~ tr/\n//) {
              $style = $flow ? YAML_DOUBLE_QUOTED_SCALAR_STYLE : YAML_LITERAL_SCALAR_STYLE;
          }
          elsif ($forbidden_first{ $first }) {
              $style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
          }
          elsif ($flow and $value =~ tr/,[]{}//) {
              $style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
          }
          elsif (substr($value, 0, 3) =~ m/^(?:---|\.\.\.)/) {
              $style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
          }
          elsif ($value =~ m/: /) {
              $style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
          }
          elsif ($value =~ m/ #/) {
              $style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
          }
          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 . '"';
      }

scripts/dex  view on Meta::CPAN

          $self->{open_ended} = 0;
          $implicit = 0; # we need ---
      }
      unless ($implicit) {
          $newline = 1;
          $self->_write("---");
      }
      $self->set_event_stack([
          {
          type => 'DOC', index => 0, indent => '', info => $info,
          newline => $newline, column => $self->column,
          }
      ]);
  }
  
  sub document_end_event {
      DEBUG and warn __PACKAGE__.':'.__LINE__.": +++ document_end_event\n";
      my ($self, $info) = @_;
      $self->set_event_stack([]);
      if ($self->{open_ended} or not $info->{implicit}) {
          $self->_write("...\n");
          $self->{open_ended} = 0;
      }
      else {
          $self->{open_ended} = 1;
      }
  }
  
  sub stream_start_event {
  }
  
  sub stream_end_event {
  }
  
  sub emit_tag {
      my ($self, $type, $tag) = @_;
      my $map = $self->tagmap;
      for my $key (sort keys %$map) {
          if ($tag =~ m/^\Q$key\E(.*)/) {
              $tag = $map->{ $key } . $1;
              return $tag;
          }
      }
      if ($tag =~ m/^(!.*)/) {
          $tag = "$1";
      }
      else {
          $tag = "!<$tag>";
      }
      return $tag;
  }
  
  sub finish {
      my ($self) = @_;
      $self->writer->finish;
  }
  
  sub _write {
      my ($self, $yaml) = @_;
      return unless length $yaml;
      my @lines = split m/\n/, $yaml, -1;
      my $newlines = @lines - 1;
      $self->{line} += $newlines;
      if (length $lines[-1]) {
          if ($newlines) {
              $self->{column} = length $lines[-1];
          }
          else {
              $self->{column} += length $lines[-1];
          }
      }
      else {
          $self->{column} = 0;
      }
      $self->writer->write($yaml);
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding utf-8
  
  =head1 NAME
  
  YAML::PP::Emitter - Emitting events
  
  =head1 SYNOPSIS
  
      my $emitter = YAML::PP::Emitter->new(
          indent => 4,
      );
  
      $emitter->init;
  
      $emitter->stream_start_event;
      $emitter->document_start_event({ implicit => 1 });
      $emitter->sequence_start_event;
      $emitter->scalar_event({ value => $input, style => $style });
      $emitter->sequence_end_event;
      $emitter->document_end_event({ implicit => 1 });
      $emitter->stream_end_event;
  
      my $yaml = $emitter->writer->output;
      $emitter->finish;
  
  =head1 DESCRIPTION
  
  The emitter emits events to YAML. It provides methods for each event
  type. The arguments are mostly the same as the events from L<YAML::PP::Parser>.
  
  =head1 METHODS
  
  =over
  
  =item new
  
      my $emitter = YAML::PP::Emitter->new(
          indent => 4,

scripts/dex  view on Meta::CPAN

      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';
                      next if $next->{name} =~ m/^(WS|SPACE)$/;
                      if ($next->{name} eq 'COLON') {
                          $token->{name} = 'PLAINKEY';
                      }
                  }
              }
              my $next = $list[ $i + 1];
              if ($next->{name} eq 'EOL') {
                  if ($str =~ m/ \z/ and $name =~ m/^(BLOCK_SCALAR_CONTENT|WS)$/) {
                      $token->{name} = "TRAILING_SPACE";
                  }
              }
          }
      }
      return @list;
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding utf-8
  
  =head1 NAME
  
  YAML::PP::Highlight - Syntax highlighting utilities
  
  =head1 SYNOPSIS
  
  
      use YAML::PP::Highlight qw/ Dump /;
  
      my $highlighted = Dump $data;
  
  =head1 FUNCTIONS
  
  =over
  
  =item Dump
  
  =back

scripts/dex  view on Meta::CPAN

          }
          $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;
      $self->callback->($self, 'stream_start_event', {
          name => 'stream_start_event',
      });
  }
  
  sub start_document {
      my ($self, $implicit) = @_;
      push @{ $self->events }, 'DOC';
      push @{ $self->offset }, -1;
      my $directive = $self->yaml_version_directive;
      my %directive;
      if ($directive) {
          my ($major, $minor) = split m/\./, $self->yaml_version;
          %directive = ( version_directive => { major => $major, minor => $minor } );
      }
      $self->callback->($self, 'document_start_event', {
          name => 'document_start_event',
          implicit => $implicit,
          %directive,
      });
      $self->set_yaml_version_directive(undef);
      $self->set_rule( 'FULLNODE' );
      $self->set_new_node(1);
  }
  
  sub start_sequence {
      my ($self, $offset) = @_;
      my $offsets = $self->offset;
      if ($offsets->[-1] == $offset) {
          push @{ $self->events }, 'SEQ0';
      }
      else {
          push @{ $self->events }, 'SEQ';
      }
      push @{ $offsets }, $offset;
      my $event_stack = $self->event_stack;
      my $info = { name => 'sequence_start_event' };
      if (@$event_stack and $event_stack->[-1]->[0] eq 'properties') {
          my $properties = pop @$event_stack;
          $self->node_properties($properties->[1], $info);
      }
      $self->callback->($self, 'sequence_start_event', $info);
  }
  
  sub start_flow_sequence {
      my ($self, $offset) = @_;
      my $offsets = $self->offset;
      my $new_offset = $offsets->[-1];
      my $event_types = $self->events;
      if ($new_offset < 0) {
          $new_offset = 0;
      }
      elsif ($self->new_node) {
          if ($event_types->[-1] !~ m/^FLOW/) {
              $new_offset++;
          }
      }
      push @{ $self->events }, 'FLOWSEQ';
      push @{ $offsets }, $new_offset;
  
      my $event_stack = $self->event_stack;
      my $info = { style => YAML_FLOW_SEQUENCE_STYLE, name => 'sequence_start_event'  };
      if (@$event_stack and $event_stack->[-1]->[0] eq 'properties') {
          $self->fetch_inline_properties($event_stack, $info);
      }
      $self->callback->($self, 'sequence_start_event', $info);
  }
  
  sub start_flow_mapping {
      my ($self, $offset) = @_;
      my $offsets = $self->offset;
      my $new_offset = $offsets->[-1];
      my $event_types = $self->events;

scripts/dex  view on Meta::CPAN

  
YAML_PP_SCHEMA_MERGE

$fatpacked{"YAML/PP/Schema/Perl.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'YAML_PP_SCHEMA_PERL';
  use strict;
  use warnings;
  package YAML::PP::Schema::Perl;
  
  our $VERSION = '0.027'; # VERSION
  
  use Scalar::Util qw/ blessed reftype /;
  
  my $qr_prefix;
  # workaround to avoid growing regexes when repeatedly loading and dumping
  # e.g. (?^:(?^:regex))
  {
      $qr_prefix = qr{\(\?-xism\:};
      if ($] >= 5.014) {
          $qr_prefix = qr{\(\?\^(?:[uadl])?\:};
      }
  }
  
  sub new {
      my ($class, %args) = @_;
      my $tags = $args{tags} || [];
      my $loadcode = $args{loadcode};
      $loadcode ||= 0;
      my $classes = $args{classes};
  
      my $self = bless {
          tags => $tags,
          loadcode => $loadcode,
          classes => $classes,
      }, $class;
  }
  
  sub register {
      my ($self, %args) = @_;
      my $schema = $args{schema};
  
      my $tags;
      my $loadcode = 0;
      my $classes;
      if (blessed($self)) {
          $tags = $self->{tags};
          @$tags = ('!perl') unless @$tags;
          $loadcode = $self->{loadcode};
          $classes = $self->{classes};
      }
      else {
          my $options = $args{options};
          my $tagtype = '!perl';
          for my $option (@$options) {
              if ($option =~ m/^tags?=(.+)$/) {
                  $tagtype = $1;
              }
              elsif ($option eq '+loadcode') {
                  $loadcode = 1;
              }
          }
          $tags = [split m/\+/, $tagtype];
      }
  
  
      my $perl_tag;
      my %tagtypes;
      my @perl_tags;
      for my $type (@$tags) {
          if ($type eq '!perl') {
              $perl_tag ||= $type;
              push @perl_tags, '!perl';
          }
          elsif ($type eq '!!perl') {
              $perl_tag ||= 'tag:yaml.org,2002:perl';
              push @perl_tags, 'tag:yaml.org,2002:perl';
          }
          else {
              die "Invalid tagtype '$type'";
          }
          $tagtypes{ $type } = 1;
      }
  
      my $perl_regex = '!perl';
      if ($tagtypes{'!perl'} and $tagtypes{'!!perl'}) {
          $perl_regex = '(?:tag:yaml\\.org,2002:|!)perl';
      }
      elsif ($tagtypes{'!perl'}) {
          $perl_regex = '!perl';
      }
      elsif ($tagtypes{'!!perl'}) {
          $perl_regex = 'tag:yaml\\.org,2002:perl';
      }
  
      my $class_regex = qr{.+};
      my $no_objects = 0;
      if ($classes) {
          if (@$classes) {
              $class_regex = '(' . join( '|', map "\Q$_\E", @$classes ) . ')';
          }
          else {
              $no_objects = 1;
              $class_regex = '';
          }
      }
  
      # Code
      if ($loadcode) {
          my $load_code = sub {
              my ($constructor, $event) = @_;
              return $self->evaluate_code($event->{value});
          };
          my $load_code_blessed = sub {
              my ($constructor, $event) = @_;
              my $class = $event->{tag};
              $class =~ s{^$perl_regex/code:}{};
              my $sub = $self->evaluate_code($event->{value});
              return $self->object($sub, $class);
          };
          $schema->add_resolver(
              tag => "$_/code",
              match => [ all => $load_code],

scripts/dex  view on Meta::CPAN

  /;
  
  use YAML::PP::Common qw/ YAML_PLAIN_SCALAR_STYLE /;
  
  #https://yaml.org/type/bool.html
  # y|Y|yes|Yes|YES|n|N|no|No|NO
  # |true|True|TRUE|false|False|FALSE
  # |on|On|ON|off|Off|OFF
  
  # https://yaml.org/type/float.html
  #  [-+]?([0-9][0-9_]*)?\.[0-9.]*([eE][-+][0-9]+)? (base 10)
  # |[-+]?[0-9][0-9_]*(:[0-5]?[0-9])+\.[0-9_]* (base 60)
  # |[-+]?\.(inf|Inf|INF) # (infinity)
  # |\.(nan|NaN|NAN) # (not a number)
  
  # https://yaml.org/type/int.html
  #  [-+]?0b[0-1_]+ # (base 2)
  # |[-+]?0[0-7_]+ # (base 8)
  # |[-+]?(0|[1-9][0-9_]*) # (base 10)
  # |[-+]?0x[0-9a-fA-F_]+ # (base 16)
  # |[-+]?[1-9][0-9_]*(:[0-5]?[0-9])+ # (base 60)
  
  # https://yaml.org/type/null.html
  #  ~ # (canonical)
  # |null|Null|NULL # (English)
  # | # (Empty)
  
  my $RE_INT_1_1 = qr{^([+-]?(?:0|[1-9][0-9_]*))$};
  #my $RE_FLOAT_1_1 = qr{^([+-]?([0-9][0-9_]*)?\.[0-9.]*([eE][+-][0-9]+)?)$};
  # https://yaml.org/type/float.html has a bug. The regex says \.[0-9.], but
  # probably means \.[0-9_]
  my $RE_FLOAT_1_1 = qr{^([+-]?(?:[0-9][0-9_]*)?\.[0-9_]*(?:[eE][+-][0-9]+)?)$};
  my $RE_SEXAGESIMAL = qr{^([+-]?[0-9][0-9_]*(:[0-5]?[0-9])+\.[0-9_]*)$};
  my $RE_SEXAGESIMAL_INT = qr{^([-+]?[1-9][0-9_]*(:[0-5]?[0-9])+)$};
  my $RE_INT_OCTAL_1_1 = qr{^([+-]?)0([0-7_]+)$};
  my $RE_INT_HEX_1_1 = qr{^([+-]?)(0x[0-9a-fA-F_]+)$};
  my $RE_INT_BIN_1_1 = qr{^([-+]?)(0b[0-1_]+)$};
  
  sub _from_oct {
      my ($constructor, $event, $matches) = @_;
      my ($sign, $oct) = @$matches;
      $oct =~ tr/_//d;
      my $result = oct $oct;
      $result = -$result if $sign eq '-';
      return $result;
  }
  sub _from_hex {
      my ($constructor, $event, $matches) = @_;
      my ($sign, $hex) = @$matches;
      my $result = hex $hex;
      $result = -$result if $sign eq '-';
      return $result;
  }
  sub _sexa_to_float {
      my ($constructor, $event, $matches) = @_;
      my ($float) = @$matches;
      my $result = 0;
      my $i = 0;
      my $sign = 1;
      $float =~ s/^-// and $sign = -1;
      for my $part (reverse split m/:/, $float) {
          $result += $part * ( 60 ** $i );
          $i++;
      }
      $result = unpack F => pack F => $result;
      return $result * $sign;
  }
  sub _to_float {
      my ($constructor, $event, $matches) = @_;
      my ($float) = @$matches;
      $float =~ tr/_//d;
      $float = unpack F => pack F => $float;
      return $float;
  }
  sub _to_int {
      my ($constructor, $event, $matches) = @_;
      my ($int) = @$matches;
      $int =~ tr/_//d;
      0 + $int;
  }
  
  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 y Y yes Yes YES on On ON /);
      $schema->add_resolver(
          tag => 'tag:yaml.org,2002:bool',
          match => [ equals => $_ => $schema->false ],
      ) for (qw/ false FALSE False n N no No NO off Off OFF /);
      $schema->add_resolver(
          tag => 'tag:yaml.org,2002:int',
          match => [ regex => $RE_INT_OCTAL_1_1 => \&_from_oct ],
      );
      $schema->add_resolver(
          tag => 'tag:yaml.org,2002:int',
          match => [ regex => $RE_INT_1_1 => \&_to_int ],
      );
      $schema->add_resolver(
          tag => 'tag:yaml.org,2002:int',
          match => [ regex => $RE_INT_HEX_1_1 => \&_from_hex ],
      );
      $schema->add_resolver(
          tag => 'tag:yaml.org,2002:float',
          match => [ regex => $RE_FLOAT_1_1 => \&_to_float ],
      );
      $schema->add_resolver(
          tag => 'tag:yaml.org,2002:int',
          match => [ regex => $RE_INT_BIN_1_1 => \&_from_oct ],
      );
      $schema->add_resolver(
          tag => 'tag:yaml.org,2002:int',
          match => [ regex => $RE_SEXAGESIMAL_INT => \&_sexa_to_float ],
      );



( run in 0.460 second using v1.01-cache-2.11-cpan-d7a12ab2c7f )