libweb-simple-perl 0.020-1 / usr / share / perl5 / Web / Dispatch / Parser.pm

package Web::Dispatch::Parser;

sub DEBUG () { 0 }

BEGIN {
  if ($ENV{WEB_DISPATCH_PARSER_DEBUG}) {
    no warnings 'redefine';
    *DEBUG = sub () { 1 }
  }
}

use Sub::Quote;
use Web::Dispatch::Predicates;
use Moo;

has _cache => (
  is => 'lazy', default => quote_sub q{ {} }
);

sub diag { if (DEBUG) { warn $_[0] } }

sub _blam {
  my ($self, $error) = @_;
  my $hat = (' ' x (pos||0)).'^';
  die "Error parsing dispatch specification: ${error}\n
${_}
${hat} here\n";
}

sub parse {
  my ($self, $spec) = @_;
  $spec =~ s/\s+//g; # whitespace is not valid
  return $self->_cache->{$spec} ||= $self->_parse_spec($spec);
}

sub _parse_spec {
  my ($self, $spec, $nested) = @_;
  return match_true() unless length($spec);
  for ($_[1]) {
    my @match;
    PARSE: { do {
      push @match, $self->_parse_spec_section($_)
        or $self->_blam("Unable to work out what the next section is");
      if (/\G\)/gc) {
        $self->_blam("Found closing ) with no opening (") unless $nested;
        last PARSE;
      }
      last PARSE if (pos == length);
      $match[-1] = $self->_parse_spec_combinator($_, $match[-1])
        or $self->_blam('No valid combinator - expected + or |');
    } until (pos == length) }; # accept trailing whitespace
    if ($nested and pos == length) {
      pos = $nested - 1;
      $self->_blam("No closing ) found for opening (");
    }
    return $match[0] if (@match == 1);
    return match_and(@match);
  }
}

sub _parse_spec_combinator {
  my ($self, $spec, $match) = @_;
  for ($_[1]) {

    /\G\+/gc and
      return $match;

    /\G\|/gc and
      return do {
        my @match = $match;
        PARSE: { do {
          push @match, $self->_parse_spec_section($_)
            or $self->_blam("Unable to work out what the next section is");
          last PARSE if (pos == length);
          last PARSE unless /\G\|/gc; # give up when next thing isn't |
        } until (pos == length) }; # accept trailing whitespace
        return match_or(@match);
      };
  }
  return;
}

sub _parse_spec_section {
  my ($self) = @_;
  for ($_[1]) {

    # ~

    /\G~/gc and
      return match_path('^$');

    # GET POST PUT HEAD ...

    /\G([A-Z]+)/gc and
      return match_method($1);

    # /...

    /\G(?=\/)/gc and
      return $self->_url_path_match($_);

    # .* and .html

    /\G\.(\*|\w+)/gc and
      return match_extension($1);

    # (...)

    /\G\(/gc and
      return $self->_parse_spec($_, pos);

    # !something

    /\G!/gc and
      return match_not($self->_parse_spec_section($_));

    # ?<param spec>
    /\G\?/gc and
      return $self->_parse_param_handler($_, 'query');

    # %<param spec>
    /\G\%/gc and
      return $self->_parse_param_handler($_, 'body');

    # *<param spec>
    /\G\*/gc and
      return $self->_parse_param_handler($_, 'uploads');
  }
  return; # () will trigger the blam in our caller
}

sub _url_path_match {
  my ($self) = @_;
  for ($_[1]) {
    my (@path, @names, $seen_nameless);
    my $end = '';
    my $keep_dot;
    PATH: while (/\G\//gc) {
      /\G\.\.\./gc
        and do {
          $end = '(/.*)';
          last PATH;
        };

      my ($segment) = $self->_url_path_segment_match($_)
        or $self->_blam("Couldn't parse path match segment");

      if (ref($segment)) {
        ($segment, $keep_dot, my $name) = @$segment;
        if (defined($name)) {
          $self->_blam("Can't mix positional and named captures in path match")
            if $seen_nameless;
          push @names, $name;
        } else {
          $self->_blam("Can't mix positional and named captures in path match")
            if @names;
          $seen_nameless = 1;
        }
      }
      push @path, $segment;

      /\G\.\.\./gc
        and do {
          $end = '(|/.*)';
          last PATH;
        };
      /\G\.\*/gc
        and $keep_dot = 1;

      last PATH if $keep_dot;
    }
    if (@path && !$end && !$keep_dot) {
      length and $_ .= '(?:\.\w+)?' for $path[-1];
    }
    my $re = '^('.join('/','',@path).')'.$end.'$';
    $re = qr/$re/;
    if ($end) {
      return match_path_strip($re, @names ? \@names : ());
    } else {
      return match_path($re, @names ? \@names : ());
    }
  }
  return;
}

sub _url_path_segment_match {
  my ($self) = @_;
  for ($_[1]) {
    # trailing / -> require / on end of URL
    /\G(?:(?=[+|\)])|$)/gc and
      return '';
    # word chars only -> exact path part match
    /
        \G(
            (?:             # start matching at a space followed by:
                    [\w\-]  # word chars or dashes
                |           # OR
                    \.      # a period
                    (?!\.)  # not followed by another period
            )
            +               # then grab as far as possible
        )
    /gcx and
      return "\Q$1";
    # ** -> capture unlimited path parts
    /\G\*\*(?:(\.\*)?\:(\w+))?/gc and
      return [ '(.*?[^/])', $1, $2 ];
    # * -> capture path part
    # *:name -> capture named path part
    /\G\*(?:(\.\*)?\:(\w+))?/gc and
      return [ '([^/]+?)', $1, $2 ];

    # :name -> capture named path part
    /\G\:(\w+)/gc and
      return [ '([^/]+?)', 0, $1 ];
  }
  return ();
}

sub _parse_param_handler {
  my ($self, $spec, $type) = @_;

  for ($_[1]) {
    my (@required, @single, %multi, $star, $multistar, %positional, $have_kw);
    my %spec;
    my $pos_idx = 0;
    PARAM: { do {

      # ?:foo or ?@:foo

      my $is_kw = /\G\:/gc;

      # ?@foo or ?@*

      my $multi = /\G\@/gc;

      # @* or *

      if (/\G\*/gc) {

        $self->_blam("* is always named; no need to supply :") if $is_kw;

        if ($star) {
          $self->_blam("Can only use one * or \@* in a parameter match");
        }

        $spec{star} = { multi => $multi };
      } else {

        # @foo= or foo= or @foo~ or foo~

        /\G([\w.]*)/gc or $self->_blam('Expected parameter name');

        my $name = $1;

        # check for = or ~ on the end

        /\G\=/gc
          ? push(@{$spec{required}||=[]}, $name)
          : (/\G\~/gc or $self->_blam('Expected = or ~ after parameter name'));

        # record positional or keyword

        push @{$spec{$is_kw ? 'named' : 'positional'}||=[]},
          { name => $name, multi => $multi };
      }
    } while (/\G\&/gc) }

    return Web::Dispatch::Predicates->can("match_${type}")->(\%spec);
  }
}

1;