URI-Nested-0.10000755000767000024 012254700630 12665 5ustar00davidstaff000000000000URI-Nested-0.10/Build.PL000444000767000024 124612254700630 14321 0ustar00davidstaff000000000000use strict; use warnings; use Module::Build; Module::Build->new( module_name => 'URI::Nested', license => 'perl', configure_requires => { 'Module::Build' => '0.30', }, build_requires => { 'Module::Build' => '0.30', 'Test::More' => '0.88', }, requires => { 'perl' => 5.008001, 'URI' => '1.40', }, meta_merge => { resources => { homepage => 'https://metacpan.org/release/URI-Nested/', bugtracker => 'https://github.com/theory/uri-nested/issues/', repository => 'https://github.com/theory/uri-nested/', } }, )->create_build_script; URI-Nested-0.10/Changes000444000767000024 14612254700630 14276 0ustar00davidstaff000000000000Revision history for Perl extension URI::Nested. 0.10 2013-12-19T23:31:12Z - Initial version. URI-Nested-0.10/MANIFEST000444000767000024 17012254700630 14131 0ustar00davidstaff000000000000Build.PL Changes lib/URI/Nested.pm MANIFEST This list of files META.json META.yml README.md t/jdbc.t t/nested_class.t URI-Nested-0.10/META.json000444000767000024 242512254700630 14446 0ustar00davidstaff000000000000{ "abstract" : "Nested URIs", "author" : [ "David E. Wheeler " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4007, CPAN::Meta::Converter version 2.132830", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "URI-Nested", "prereqs" : { "build" : { "requires" : { "Module::Build" : "0.30", "Test::More" : "0.88" } }, "configure" : { "requires" : { "Module::Build" : "0.30" } }, "runtime" : { "requires" : { "URI" : "1.40", "perl" : "5.008001" } } }, "provides" : { "URI::Nested" : { "file" : "lib/URI/Nested.pm", "version" : "0.10" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/theory/uri-nested/issues/" }, "homepage" : "https://metacpan.org/release/URI-Nested/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/theory/uri-nested/" } }, "version" : "0.10" } URI-Nested-0.10/META.yml000444000767000024 135112254700630 14273 0ustar00davidstaff000000000000--- abstract: 'Nested URIs' author: - 'David E. Wheeler ' build_requires: Module::Build: 0.30 Test::More: 0.88 configure_requires: Module::Build: 0.30 dynamic_config: 1 generated_by: 'Module::Build version 0.4007, CPAN::Meta::Converter version 2.132830' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: URI-Nested provides: URI::Nested: file: lib/URI/Nested.pm version: 0.10 requires: URI: 1.40 perl: 5.008001 resources: bugtracker: https://github.com/theory/uri-nested/issues/ homepage: https://metacpan.org/release/URI-Nested/ license: http://dev.perl.org/licenses/ repository: https://github.com/theory/uri-nested/ version: 0.10 URI-Nested-0.10/README.md000444000767000024 163612254700630 14307 0ustar00davidstaff000000000000URI/Nested version 0.10 ======================= This library implements a Perl interface for nested URIs -- that is, URIs that contain other URIs. The basic format is: {prefix}:{uri} Some examples: * `jdbc:oracle:scott/tiger@//myhost:1521/myservicename` * `db:postgres://db.example.com/template1` Implementations built on URI::Nested include [URI::jdbc](https://metacpan.org/module/URI::jdbc) and [URI::db](https://metacpan.org/module/URI::db). Installation ------------ To install this module, type the following: perl Build.PL ./Build ./Build test ./Build install Dependencies ------------ URI::Nested requires the following modules: * [URI](https://metacpan.org/module/URI) Copyright and Licence --------------------- Copyright (c) 2013 David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. URI-Nested-0.10/lib000755000767000024 012254700630 13433 5ustar00davidstaff000000000000URI-Nested-0.10/lib/URI000755000767000024 012254700630 14072 5ustar00davidstaff000000000000URI-Nested-0.10/lib/URI/Nested.pm000444000767000024 1423012254700630 16027 0ustar00davidstaff000000000000package URI::Nested; use strict; use 5.8.1; our $VERSION = '0.10'; use overload '""' => 'as_string', fallback => 1; sub prefix { my $class = ref $_[0] || shift; return (split /::/ => $class)[-1]; } sub nested_class { undef } sub new { my ($class, $str, $base) = @_; my $prefix = $class->prefix; my $scheme; if ($base) { # Remove prefix and grab the scheme to use for the nested URI. $base =~ s/^\Q$prefix://; ($scheme) = $base =~ /^($URI::scheme_re):/; } my $uri = URI->new($str, $base); return $uri if $uri->isa(__PACKAGE__); # Convert to a nested URI and assign the scheme, if needed. $uri->scheme($scheme) if $scheme && !$uri->scheme; if ( my $nested_class = $class->nested_class ) { bless $uri => $nested_class unless $uri->isa($nested_class); } bless [ $prefix => $uri ] => $class; } sub new_abs { my ($class, $uri, $base) = @_; $uri = URI->new($uri); # No change if already have a scheme. return $uri if $uri->scheme; $base = URI->new($base); # Return non-nested absolute. return $uri->abs($base) unless $base->isa(__PACKAGE__); # Return nested absolute. $uri = $uri->abs( $base->[1] ) if $base->[1]; $base->[1] = $uri; return $base; } sub _init { my ($class, $str, $scheme) = @_; my $prefix = quotemeta $class->prefix; if ($str =~ s/^($prefix)://i) { $scheme = $1; } return $class->_nested_init($scheme, $str); } sub _nested_init { my ($class, $scheme, $str) = @_; my $uri = URI->new($str); if ( my $nested_class = $class->nested_class ) { bless $uri => $nested_class unless $uri->isa($nested_class); } bless [ $scheme, $uri ] => $class; } sub nested_uri { shift->[1] } sub scheme { my $self = shift; return lc $self->[0] unless @_; my $new = shift; my $old = $self->[0]; # Cannot change $self from array ref to scalar ref, so reject other schemes. Carp::croak('Cannot change ', ref $self, ' scheme' ) if lc $new ne $self->prefix; $self->[0] = $new; return $old; } sub as_string { return join ':', @{ +shift }; } sub clone { my $self = shift; bless [$self->[0], $self->[1]->clone], ref $self; } sub abs { shift } sub rel { shift } sub eq { my ($self, $other) = @_; $other = URI->new($other) unless ref $other; return ref $self eq ref $other && $self->[1]->eq($other->[1]); } sub _init_implementor {} # Hard-code common accessors and methods. sub opaque { shift->[1]->opaque(@_) } sub path { shift->[1]->path(@_) } sub fragment { shift->[1]->fragment(@_) } sub host { shift->[1]->host(@_) } sub port { shift->[1]->port(@_) } sub _port { shift->[1]->_port(@_) } sub authority { shift->[1]->authority(@_) } sub path_query { shift->[1]->path_query(@_) } sub path_segments { shift->[1]->path_segments(@_) } sub query { shift->[1]->query(@_) } sub userinfo { shift->[1]->userinfo(@_) } # Catch any missing methods. our $AUTOLOAD; sub AUTOLOAD { my $self = shift; my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); return if $method eq 'DESTROY'; $self->[1]->$method(@_); } sub can { # override UNIVERSAL::can my $self = shift; $self->SUPER::can(@_) || ( ref($self) ? $self->[1]->can(@_) : undef ); } 1; __END__ =head1 Name URI::Nested - Nested URIs =head1 Synopsis package URI::jdbc; use parent 'URI::Nested'; sub prefix { 'jdbc' } sub nested_class { undef } sub subprotocol { shift->nested_uri->scheme(@_) } package main; my $jdbc_uri = URI->new('jdbc:oracle:scott/tiger@//myhost:1521/myservicename'); my $nested_uri = $jdbc_uri->nested_uri; =head1 Description This class provides support for nested URIs, where the scheme is a prefix, and the remainder of the URI is another URI. Examples include L and L. =head1 Interface The following differences exist compared to the C class interface: =head2 Class Method =head3 C Returns the prefix to be used, which corresponds to the URI's scheme. Defaults to the last part of class name. =head3 C Returns the URI subclass to use for the nested URI. If defined, the nested URI will always be coerced into this class if it is not naturally an instance of this class or one of its subclasses. =head2 Constructors =head3 C my $uri = URI::Nested->new($string); my $uri = URI::Nested->new($string, $base); Always returns a URI::Nested object. C<$base> may be another URI object or string. Unlike in L's C, schemes will always be applied to the URI and the nested URI if they does not already schemes. And if C is defined, the nested URI will be coerced into that class. =head2 Accessors =head3 C my $scheme = $uri->scheme; $uri->scheme( $new_scheme ); Gets or sets the scheme part of the URI. When setting the scheme, it must always be the same as the value returned by C or an exception will be thrown -- although the letter casing may vary. The returned value is always lowercase. =head3 C my $nested_uri = $uri->nested_uri; Returns the nested URI. =head2 Instance Methods =head3 C my $abs = $uri->abs( $base_uri ); Returns the URI::Nested object itself. Unlike L's C, C<$URI::ABS_ALLOW_RELATIVE_SCHEME> is ignored. =head3 C my $rel = $uri->rel( $base_uri ); Returns the URI::Nested object itself. =head1 Support This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 Author David E. Wheeler =head1 Copyright and License Copyright (c) 2013 David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut URI-Nested-0.10/t000755000767000024 012254700630 13130 5ustar00davidstaff000000000000URI-Nested-0.10/t/jdbc.t000444000767000024 331212254700630 14353 0ustar00davidstaff000000000000#!/usr/bin/perl -w use strict; use Test::More; use utf8; use URI; JDBC: { package URI::jdbc; use base 'URI::Nested'; } is +URI::jdbc->prefix, 'jdbc', 'Prefix should be "jdbc"'; isa_ok my $uri = URI->new('jdbc:'), 'URI::jdbc', 'Empty JDBC URI'; is $uri->scheme, 'jdbc', 'Empty JDBC URI should have scheme "jdbc"'; isa_ok $uri->nested_uri, 'URI::_generic', 'Nested URI'; ok $uri->nested_uri->eq(URI->new('')), 'Nested URI should be empty'; ok $uri->eq('jdbc:'), 'URI should eq "jdbc:"'; is $uri->as_string, 'jdbc:', 'String should be "jdbc:"'; # Try a more interesting URI. my $str = 'jdbc:oracle:scott/tiger@//myhost:1521/myservicename'; isa_ok $uri = URI->new($str), 'URI::jdbc', 'Oracle JDBC URI'; is $uri->scheme, 'jdbc', 'Oracle JDBC URI should have scheme "jdbc"'; ok $uri->eq($str), 'Oracle JDBC URI should eq string'; is $uri->as_string, $str, 'Oracle JDBC String should be correct'; # Check the nested URI. $str =~ s/^jdbc://; isa_ok $uri = $uri->nested_uri, 'URI::_generic', 'Nested Oracle URI'; ok $uri->eq($str), 'Oracle URI should eq string'; is $uri->as_string, $str, 'Oracle String should be correct'; # Try a Postgres URL. $str = 'jdbc:postgresql://localhost/test?user=fred&password=secret&ssl=true'; isa_ok $uri = URI->new($str), 'URI::jdbc', 'Postgres JDBC URI'; is $uri->scheme, 'jdbc', 'Postgres JDBC URI should have scheme "jdbc"'; ok $uri->eq($str), 'Postgres JDBC URI should eq string'; is $uri->as_string, $str, 'Postgres JDBC String should be correct'; # Check the nested URI. $str =~ s/^jdbc://; isa_ok $uri = $uri->nested_uri, 'URI::_generic', 'Nested Postgres URI'; ok $uri->eq($str), 'Postgres URI should eq string'; is $uri->as_string, $str, 'Postgres String should be correct'; done_testing; URI-Nested-0.10/t/nested_class.t000444000767000024 1254512254700630 16150 0ustar00davidstaff000000000000#!/usr/bin/perl -w use strict; use Test::More; use utf8; use URI; use URI::QueryParam; SUBCLASS: { package URI::_blah; use base 'URI::_login'; package URI::blah; use base 'URI::Nested'; sub prefix { 'blah' } sub nested_class { 'URI::_blah' } } isa_ok my $uri = URI->new('blah:'), 'URI::blah', 'Opaque BLAH URI'; is $uri->scheme, 'blah', 'BLAH URI with no engine should have scheme "blah"'; # Try changing the scheme. is $uri->scheme('Blah'), 'blah', 'Change scheme to "Blah"'; isa_ok $uri, 'URI::blah'; is $uri->scheme, 'blah', 'New scheme should still be "blah"'; is $uri->as_string, 'Blah:', 'Should stringify with the new scheme'; # Change the scheme to something other than blah. eval { $uri->scheme('foo') }; ok my $err = $@, 'Should get error changing to non-BLAH scheme'; like $err, qr/Cannot change URI::blah scheme/, 'Should be the proper error'; # Now use a non-blah-qalified URI. isa_ok $uri = URI->new('nonesuch:'), 'URI::_foreign', 'Opaque Nonesuch URI'; is $uri->scheme, 'nonesuch', 'Nonesuch URI scheme should be "nonesuch"'; # Try constructor. isa_ok $uri = URI::blah->new('nonesuch:'), 'URI::blah', 'nonesuch URI'; isa_ok $uri->nested_uri, 'URI::_blah', 'nonesuch URI URI'; is $uri->as_string, 'blah:nonesuch:', 'nonesuch URI should be correct'; # Should convert non-blah URI to a blah URI. isa_ok $uri = URI::blah->new('foo:'), 'URI::blah', 'foo URI'; isa_ok $uri->nested_uri, 'URI::_blah', 'foo URI URI'; is $uri->as_string, 'blah:foo:', 'foo URI should be correct'; # Should pay attention to base URI. isa_ok $uri = URI::blah->new('foo', 'nonesuch:'), 'URI::blah', 'blah URI with nonesuch base'; isa_ok $uri->nested_uri, 'URI::_blah', 'blah:nonesuch URI'; is $uri->as_string, 'blah:nonesuch:foo', 'blah URI with nonesuch: base should be correct'; # Should pay attention to blah: base URI. isa_ok $uri = URI::blah->new('foo', 'blah:'), 'URI::blah', 'blah URI with blah base'; isa_ok $uri->nested_uri, 'URI::_blah', 'blah base URI'; is $uri->as_string, 'blah:foo', 'blah URI with blah: base should be correct'; # Should pay attention to blah:nonesuch base URI. isa_ok $uri = URI::blah->new('foo', 'blah:nonesuch'), 'URI::blah', 'blah URI with blah:nonesuch base'; isa_ok $uri->nested_uri, 'URI::_blah', 'blah:nonesuch base URI'; is $uri->as_string, 'blah:foo', 'blah URI with blah:nonesuch base should be correct'; # Try with a blah:nonesuch base. my $base = URI->new('blah:nonesuch'); isa_ok $uri = URI::blah->new('foo', $base), 'URI::blah', 'blah URI with obj base'; isa_ok $uri->nested_uri, 'URI::_blah', 'obj base URI'; is $uri->as_string, 'blah:foo', 'blah URI with obj base should be correct'; isa_ok $base, 'URI::blah', 'base URI'; # Try with a blah: base. $base = URI->new('blah:'); isa_ok $uri = URI::blah->new('foo', $base), 'URI::blah', 'blah URI with blah obj base'; isa_ok $uri->nested_uri, 'URI::_blah', 'blah obj base URI'; is $uri->as_string, 'blah:foo', 'blah URI with blah obj base should be correct'; isa_ok $base, 'URI::blah', 'base URI'; # Try blah:unknown. $base = URI->new('blah:unknown:'); isa_ok $uri = URI::blah->new('foo', $base), 'URI::blah', 'blah URI with obj base'; isa_ok $uri->nested_uri, 'URI::_blah', 'obj base URI'; is $uri->as_string, 'blah:unknown:foo', 'blah URI with obj base should be correct'; isa_ok $base, 'URI::blah', 'base URI'; # Try with some other base. $base = URI->new('bar:'); isa_ok $uri = URI::blah->new('foo', $base), 'URI::blah', 'blah URI with obj base'; isa_ok $uri->nested_uri, 'URI::_blah', 'obj base URI'; is $uri->as_string, 'blah:bar:foo', 'blah URI with obj base should be correct'; isa_ok $base, 'URI', 'bar base URI'; # Try new_abs. isa_ok $uri = URI::blah->new_abs('foo', 'nonesuch:'), 'URI::_foreign'; is $uri->as_string, 'nonesuch:/foo', 'Should have nonesuch: URI'; isa_ok $uri = URI::blah->new_abs('foo', 'blah:nonesuch:'), 'URI::blah'; is $uri->as_string, 'blah:nonesuch:/foo', 'Should have blah:nonesuch: URI'; isa_ok $uri = URI::blah->new_abs('foo', 'blah:'), 'URI::blah'; is $uri->as_string, 'blah:foo', 'Should have blah: URI'; isa_ok $uri = URI::blah->new_abs('foo', 'bar:'), 'URI::_generic'; isa_ok $uri = URI::blah->new_abs('foo', 'file::'), 'URI::file'; isa_ok $uri = URI::blah->new_abs('nonesuch:foo', 'nonesuch:'), 'URI::_foreign'; is $uri->as_string, 'nonesuch:foo', 'Should have nonesuch:foo URI'; isa_ok $uri = URI::blah->new_abs('blah:foo', 'blah:'), 'URI::blah'; is $uri->as_string, 'blah:foo', 'Should have blah:foo URI'; isa_ok $uri = URI::blah->new_abs('blah:nonesuch:foo', 'blah:nonesuch:'), 'URI::blah'; is $uri->as_string, 'blah:nonesuch:foo', 'Should have blah:nonesuch:foo URI'; # Test abs. isa_ok $uri = URI->new('blah:nonesuch:'), 'URI::blah'; is overload::StrVal( $uri->abs('file:/hi') ), overload::StrVal($uri), 'abs should return URI object itself'; # Test rel. is overload::StrVal( $uri->rel('file:/hi') ), overload::StrVal($uri), 'rel should return URI object itself'; # Test clone. is $uri->clone, $uri, 'Clone should return dupe URI'; isnt overload::StrVal( $uri->clone ), overload::StrVal($uri), 'Clone should not return self'; # Test eq. can_ok $uri, 'eq'; ok $uri->eq($uri), 'URI should equal itself'; ok $uri->eq($uri->as_string), 'URI should equal itself stringified'; ok $uri->eq(URI->new( $uri->as_string )), 'URI should equal equiv URI'; ok $uri->eq($uri->clone), 'URI should equal itself cloned'; ok !$uri->eq('nonesuch:'), 'URI should not equal non-BLAH URI'; done_testing;