uri_template_draft08

parser.pl

#!/usr/bin/env perl

use strict;
use warnings;
use Data::Dump qw(dump);

my $t = $ARGV[0];

our %RE;
$RE{ALPHA} = qr/[A-Za-z]/;
$RE{DIGIT} = qr/[0-9]/;
$RE{HEXDIG} = qr/(?:$RE{DIGIT}|[A-F])/xi;
$RE{pct_encoded} = qr/\%${RE{HEXDIG}}{2}/x;
$RE{unreserved}  = qr/(?:${RE{ALPHA}}|${RE{DIGIT}}|\-|\.|_|~)/x;
$RE{gen_delims}  = qr/(?:\:|\/|\?|\#|\[|\]|\@)/x;
$RE{sub_delims}  = qr/(?:\!|\$|\&|'|\(|\)|\*|\+|,|;|=)/x;
$RE{ucschar}    = qr/(?:
    [\x{A0}-\x{D7FF}]|
    [\x{F900}-\x{FDCF}]|
    [\x{FDF0}-\x{FFEF}]|
    [\x{10000}-\x{1FFFD}]|
    [\x{20000}-\x{2FFFD}]|
    [\x{30000}-\x{3FFFD}]|
    [\x{40000}-\x{4FFFD}]|
    [\x{50000}-\x{5FFFD}]|
    [\x{60000}-\x{6FFFD}]|
    [\x{70000}-\x{7FFFD}]|
    [\x{80000}-\x{8FFFD}]|
    [\x{90000}-\x{9FFFD}]|
    [\x{A0000}-\x{AFFFD}]|
    [\x{B0000}-\x{BFFFD}]|
    [\x{C0000}-\x{CFFFD}]|
    [\x{D0000}-\x{DFFFD}]|
    [\x{E1000}-\x{EFFFD}]
)/x;
$RE{iprivate} = qr/(?:
    [\x{E000}-\x{F8FF}]|
    [\x{F0000}-\x{FFFFD}]|
    [\x{100000}-\x{10FFFD}]
)/x;

## literals
$RE{literals} = qr/(?:
    [\x21\x23\x24\x26\x28-\x3B\x3D\x3F-\x5B\x5D\x5F\x61-\x7A|\x7E]|
    $RE{ucschar}|
    $RE{iprivate}|
    $RE{pct_encoded}
)/x;

## modifier_level4
$RE{explode} = qr/\*/;
$RE{max_length} = qr/(?:[1-9]${RE{DIGIT}}{0,3})/x;
$RE{prefix} = qr/(?:\:(?:$RE{max_length}))/x;
$RE{modifier_level4} = qr{(?:$RE{prefix}|$RE{explode})}x;

## variable_list
$RE{varchar} = qr/(?:
    $RE{ALPHA}|
    $RE{DIGIT}|
    _|
    $RE{pct_encoded}
)/x;
$RE{varname} = qr/(?:
    $RE{varchar}
    (?:\.?$RE{varchar})*
)/x;
$RE{varspec} = qr/(?:($RE{varname})(${RE{modifier_level4}})?)/x;
$RE{variable_list} = qr/(?:$RE{varspec})(?:,$RE{varspec})*/x;

## expression
$RE{op_reserve} = qr/(?:=|,|!|@|\|)/x;
$RE{op_level3}  = qr/(?:\.|\/|;|\?|&)/x;
$RE{op_level2}  = qr/[\+#]/;
$RE{operator}   = qr/(?:$RE{op_level2}|$RE{op_level3}|$RE{op_reserve})/x;
$RE{expression} = qr/
    \{
    (${RE{operator}})?
    (${RE{variable_list}})
    \}
/x;

$RE{uri_template} = qr/(?:($RE{literals}+)|($RE{expression}))/x;

$DB::single = 2;

my @patterns;
my $literals = "";

while ((my @m = ( $t =~ m/$RE{uri_template}/x )) > 0) {
    if (@m > 0) {
        $t = $';
        dump(@m);

        if ($m[0]) {
            $literals .= $m[0];
        }
        else {
            if (length $literals > 0) {
                push(@patterns, $literals);
                $literals = "";
            }

            push(@patterns, $m[1]);
        }
    }
}
if (length $literals > 0) {
    push(@patterns, $literals);
}

dump(@patterns);