view release on metacpan or  search on metacpan

lib/MarpaX/Role/Parameterized/ResourceIdentifier/BNF.pm  view on Meta::CPAN

# ---------------------------------------------------
use constant {
  URI_CONVERTED              =>  0,
  IRI_CONVERTED              =>  1,

  _MAX_CONVERTER             =>  1,
  _COUNT_CONVERTER           =>  2
};
#
# Depending on the "spec" attribute we will call one
# converter only. If spec is "uri" we call conversion to iri.
# If spec is "iri" we call conversion to uri. Though there
# remains two possible converters:
#
our @converter_names = qw/uri_converter iri_converter/;

# -----
# Other
# -----
our @ucs_mime_name = map { find_encoding($_)->mime_name } qw/UTF-8 UTF-16 UTF-16BE UTF-16LE UTF-32 UTF-32BE UTF-32LE/;

# ------------------------------------------------------------
# Explicit slots for all supported attributes in input
# scheme is explicitely ignored, it is handled only by _top
# ------------------------------------------------------------
has input                   => ( is => 'rwp', isa => StringLike                            );
has has_recognized_scheme   => ( is => 'rw',  isa => Bool,        default => sub {   !!0 } );
has is_character_normalized => ( is => 'rwp', isa => Bool,        default => sub {   !!1 } );
#
# Implementations should 'around' the folllowings
#
has pct_encoded                     => ( is => 'ro',  isa => Str|Undef,       lazy => 1, builder => 'build_pct_encoded' );
has unreserved                      => ( is => 'ro',  isa => RegexpRef|Undef, lazy => 1, builder => 'build_unreserved' );
has reserved                        => ( is => 'ro',  isa => RegexpRef|Undef, lazy => 1, builder => 'build_reserved' );
has default_port                    => ( is => 'ro',  isa => Int|Undef,       lazy => 1, builder => 'build_default_port' );
has reg_name_convert_as_domain_name => ( is => 'ro',  isa => Bool,            lazy => 1, builder => 'build_reg_name_convert_as_domain_name' );
has current_location                => ( is => 'ro',  isa => Str|Undef,       lazy => 1, builder => 'build_current_location' );
has parent_location                 => ( is => 'ro',  isa => Str|Undef,       lazy => 1, builder => 'build_parent_location' );
has separator_location              => ( is => 'ro',  isa => Str|Undef,       lazy => 1, builder => 'build_separator_location' );
__PACKAGE__->_generate_attributes('normalizer', @normalizer_names);
__PACKAGE__->_generate_attributes('converter',  @converter_names);

# ------------------------------------------------------------------------------------------------
# Internal slots: one for the raw parse, one for the normalized value, one for the converted value
# ------------------------------------------------------------------------------------------------
has _orig_arg               => ( is => 'rw',  isa => Any );   # For cloning
has _structs                => ( is => 'rw',  isa => ArrayRef[Object] );
use constant {
  _RAW_STRUCT               =>  0,
  _NORMALIZED_STRUCT        =>  1,
  _ESCAPED_STRUCT           =>  2,
  _UNESCAPED_STRUCT         =>  3,
  _CONVERTED_STRUCT         =>  4,

  _MAX_STRUCTS              =>  4,
  _COUNT_STRUCTS            =>  5
};
#
# Just a helper for me
#
has _indice_description     => ( is => 'ro',  isa => ArrayRef[Str], default => sub {
                                   [
                                    'Raw structure       ',
                                    'Normalized structure',
                                    'Escaped structure',
                                    'Unescaped structure',
                                    'Converted structure '
                                   ]
                                 }
                               );
#
# Generic helpers that will always work
#
sub raw                 { $_[0]->{_structs}->[       _RAW_STRUCT]->{$_[1] // 'output'} }
sub raw_scheme          { $_[0]->raw('scheme')   }
sub raw_opaque          { $_[0]->raw('opaque')   }
sub raw_fragment        { $_[0]->raw('fragment') }

sub normalized          { $_[0]->{_structs}->[_NORMALIZED_STRUCT]->{$_[1] // 'output'} }
sub normalized_scheme   { $_[0]->normalized('scheme')   }
sub normalized_opaque   { $_[0]->normalized('opaque')   }
sub normalized_fragment { $_[0]->normalized('fragment') }

sub escaped             { $_[0]->{_structs}->[   _ESCAPED_STRUCT]->{$_[1] // 'output'} }
sub escaped_scheme      { $_[0]->escaped('scheme')   }
sub escaped_opaque      { $_[0]->escaped('opaque')   }
sub escaped_fragment    { $_[0]->escaped('fragment') }

sub unescaped           { $_[0]->{_structs}->[ _UNESCAPED_STRUCT]->{$_[1] // 'output'} }
sub unescaped_scheme    { $_[0]->unescaped('scheme')   }
sub unescaped_opaque    { $_[0]->unescaped('opaque')   }
sub unescaped_fragment  { $_[0]->unescaped('fragment') }

sub converted           { $_[0]->{_structs}->[ _CONVERTED_STRUCT]->{$_[1] // 'output'} }
sub converted_scheme    { $_[0]->converted('scheme')   }
sub converted_opaque    { $_[0]->converted('opaque')   }
sub converted_fragment  { $_[0]->converted('fragment') }
#
# Let's be always URI compatible for the canonical method
#
sub canonical  { goto &normalized }
#
# as_string returns the perl string
#
sub as_string  { goto &raw }

# =======================================================================
# We want parsing to happen immedately AFTER object was built and then at
# every input reconstruction
# =======================================================================
our $check_BUILDARGS      = compile(StringLike|HashRef);
our $check_BUILDARGS_Dict = compile(slurpy Dict[
                                                input                           => Optional[StringLike],
                                                octets                          => Optional[Bytes],
                                                encoding                        => Optional[Str],
                                                decode_strategy                 => Optional[Any],
                                                is_character_normalized         => Optional[Bool],
                                                reg_name_convert_as_domain_name => Optional[Bool],
                                                current_location                => Optional[Str],
                                                parent_location                 => Optional[Str],
                                                separator_location              => Optional[Str]

lib/MarpaX/Role/Parameterized/ResourceIdentifier/BNF.pm  view on Meta::CPAN

  # path, then return a string consisting of "/" concatenated with the
  # reference's path; otherwise,
  #
  if (defined($base->{authority}) && ! length($base->{path})) {
    return $ref->{separator_location} . $ref->{path};
  }
  #
  # return a string consisting of the reference's path component
  # appended to all but the last segment of the base URI's path (i.e.,
  # excluding any characters after the right-most "/" in the base URI
  # path, or excluding the entire base URI path if it does not contain
  # any "/" characters).
  #
  else {
    my $base_path = $base->{path};
    if ($base_path !~ /\//) {
      $base_path = '';
    } else {
      $base_path =~ s/\/[^\/]*\z/\//;
    }
    return $base_path . $ref->{path};
  }
}

sub _recompose {
  my ($class, $T) = @_;
  #
  # https://tools.ietf.org/html/rfc3986
  #
  # 5.3.  Component Recomposition
  #
  # We are compatiblee with both common and generic syntax:
  # - the common  case can have only scheme, path (== opaque) and fragment
  # - the generic case can have scheme, authority, path, query and fragment
  #
  my $result = '';
  $result .=        $T->{scheme} . ':' if (defined $T->{scheme});
  if (defined $T->{opaque}) {
    $result .=        $T->{opaque};
  } else {
    $result .= '//' . $T->{authority}    if (defined $T->{authority});
    $result .=        $T->{path};
    $result .= '?'  . $T->{query}        if (defined $T->{query});
  }
  $result .= '#'  . $T->{fragment}     if (defined $T->{fragment});

  $result
}

# =============================================================================
# Internal class methods
# =============================================================================
sub _generate_attributes {
  my ($class, $type, @names) = @_;

  #
  # The lazy builders that implementation should around
  #
  foreach (@names) {
    my $builder = "build_$_";
    has $_ => (is => 'ro', isa => HashRef[CodeRef],
               lazy => 1,
               builder => $builder,
               handles_via => 'Hash',
               handles => {
                           "get_$_"    => 'get',
                           "set_$_"    => 'set',
                           "exists_$_" => 'exists',
                           "delete_$_" => 'delete',
                           "kv_$_"     => 'kv',
                           "keys_$_"   => 'keys',
                           "values_$_" => 'values',
                          }
              );
  }

  my $_type_names                     = "_${type}_names";
  my $_type_wrapper                   = "_${type}_wrapper";
  my $_type_wrapper_call_lazy_builder = "_${type}_wrapper_call_lazy_builder";
  #
  # Just a convenient thing for us
  #
  has $_type_names   => (is => 'ro', isa => ArrayRef[Str|Undef], default => sub { \@names });
  #
  # The important thing is these wrappers:
  # - the one using accessors so that we are sure builders are executed
  # - the one without the accessors for performance
  #
  has $_type_wrapper => (is => 'ro', isa => ArrayRef[CodeRef|Undef],
                         # lazy => 1,                              Not lazy and this is INTENTIONAL
                         handles_via => 'Array',
                         handles => {
                                     "_get_$type" => 'get'
                                    },
                         default => sub {
                           $_[0]->_build_impl_sub(0, @names)
                         }
                        );
  has $_type_wrapper_call_lazy_builder => (is => 'ro', isa => ArrayRef[CodeRef|Undef],
                                        # lazy => 1,                              Not lazy and this is INTENTIONAL
                                        handles_via => 'Array',
                                        handles => {
                                                    "_get_${type}_call_lazy_builder" => 'get'
                                                   },
                                        default => sub {
                                          $_[0]->_build_impl_sub(1, @names)
                                        }
                                       );
}
# =============================================================================
# Internal instance methods
# =============================================================================
sub _build_impl_sub {
  my ($self, $call_builder, @names) = @_;

  my @array = ();
  foreach my $name (@names) {
    my $exists = "exists_$name";
    my $getter = "get_$name";
    #
    # We KNOW in advance that we are talking with a hash. So no need to
    # to do extra calls. The $exists and $getter variables are intended
    # for the outside world.
    # The inlined version using these accessors is:
    my $inlined_call_lazy_builder = <<INLINED_CALL_LAZY_BUILDER;
  # my (\$self, \$criteria, \$value) = \@_;
  #
  # This is intentionnaly doing NOTHING, but call the builders -;
  #
  \$_[0]->$exists(\$_[1])
INLINED_CALL_LAZY_BUILDER
    # The inlined version using direct perl op is:
    my $inlined_without_accessors = <<INLINED_WITHOUT_ACCESSORS;
  # my (\$self, \$criteria, \$value) = \@_;
  #
  # At run-time, in particular Protocol-based normalizers,
  # the callbacks can be altered
  #
  exists(\$_[0]->{$name}->{\$_[1]}) ? goto \$_[0]->{$name}->{\$_[1]} : \$_[2]
INLINED_WITHOUT_ACCESSORS
    if ($call_builder) {
      push(@array,eval "sub {$inlined_call_lazy_builder}") ## no critic
    } else {
      push(@array,eval "sub {$inlined_without_accessors}") ## no critic
    }
  }
  \@array
}

BEGIN {
  #
  # Marpa internal optimisation: we do not want the closures to be rechecked every time
  # we call $r->value(). This is a static information, although determined at run-time
  # the first time $r->value() is called on a recognizer.
  #
  no warnings 'redefine';

  sub Marpa::R2::Recognizer::registrations {
    my $recce = shift;