Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

import URI::tag

  • Loading branch information...
commit 836092fe8917e62b4bbde5b103646fda6e12fa1f 1 parent b038758
@miyagawa authored
View
4 Changes
@@ -0,0 +1,4 @@
+Revision history for Perl extension URI::tag
+
+ 0.01 Fri Sep 8 03:09:20 2006
+ - original version
View
25 MANIFEST
@@ -0,0 +1,25 @@
+Changes
+inc/Module/Install.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/TestBase.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+inc/Spiffy.pm
+inc/Test/Base.pm
+inc/Test/Base/Filter.pm
+inc/Test/Builder.pm
+inc/Test/Builder/Module.pm
+inc/Test/More.pm
+lib/URI/tag.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+README
+t/00_compile.t
+t/01_tag.t
+t/99_pod.t
View
11 MANIFEST.SKIP
@@ -0,0 +1,11 @@
+\bRCS\b
+\bCVS\b
+^MANIFEST\.
+^Makefile$
+~$
+\.old$
+^blib/
+^pm_to_blib
+^MakeMaker-\d
+\.gz$
+\.cvsignore
View
8 Makefile.PL
@@ -0,0 +1,8 @@
+use inc::Module::Install;
+name 'URI-tag';
+all_from 'lib/URI/tag.pm';
+
+build_requires 'Test::More';
+use_test_base;
+auto_include;
+WriteAll;
View
27 README
@@ -0,0 +1,27 @@
+This is Perl module URI::tag.
+
+INSTALLATION
+
+URI::tag installation is straightforward. If your CPAN shell is set up,
+you should just be able to do
+
+ % cpan URI::tag
+
+Download it, unpack it, then build it as per the usual:
+
+ % perl Makefile.PL
+ % make && make test
+
+Then install it:
+
+ % make install
+
+DOCUMENTATION
+
+URI::tag documentation is available as in POD. So you can do:
+
+ % perldoc URI::tag
+
+to read the documentation online with your favorite pager.
+
+Tatsuhiko Miyagawa
View
97 lib/URI/tag.pm
@@ -0,0 +1,97 @@
+package URI::tag;
+
+use strict;
+our $VERSION = '0.01';
+
+use base qw(URI);
+
+sub authority {
+ my $self = shift;
+ $self->_accessor('authority', @_);
+}
+
+sub date {
+ my $self = shift;
+ $self->_accessor('date', @_);
+}
+
+sub specific {
+ my $self = shift;
+ $self->_accessor('specific', @_);
+}
+
+sub _accessor {
+ my $self = shift;
+ my $attr = shift;
+
+ my $stuff = $self->_from_opaque($self->opaque);
+ my $old = $stuff->{$attr};
+ if (@_) {
+ $stuff->{$attr} = shift;
+ $self->opaque( $self->_to_opaque($stuff) );
+ }
+ return $old;
+}
+
+sub _from_opaque {
+ my($self, $opaque) = @_;
+
+ # relaxed regexp rather than from the ABNF in RFC 4151
+ my $stuff;
+ $opaque =~ /^([\w\-\.\@]*)(?:,(\d{4}(?:-\d\d(?:-\d\d)?)?)?(?::([$URI::uric]*))?)?$/;
+ $stuff->{authority} = $1;
+ $stuff->{date} = $2;
+ $stuff->{specific} = $3;
+
+ $stuff;
+}
+
+sub _to_opaque {
+ my($self, $stuff) = @_;
+
+ sprintf "%s,%s:%s", map { $stuff->{$_} || '' } qw( authority date specific );
+}
+
+1;
+__END__
+
+=head1 NAME
+
+URI::tag - Tag URI Scheme (RFC 4151)
+
+=head1 SYNOPSIS
+
+ use URI;
+ use URI::tag;
+
+ my $uri = URI->new("tag:my-ids.com,2001-09-15:blog-555");
+
+ $uri->authority; # my-ids.com
+ $uri->date; # 2001-09-15
+ $uri->specific; # blog-555
+
+ $uri = URI->new("tag:");
+ $uri->authority("example.com");
+ $uri->date("2006-09-22");
+ $uri->specific("blahblah");
+
+ print $uri->as_string; # tag:example.com,2006-09-22:blahblah
+
+=head1 DESCRIPTION
+
+URI::tag is an URI class that represents Tag URI Scheme, defined in RFC 4151.
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<http://www.ietf.org/rfc/rfc4151.txt>
+
+=cut
View
4 t/00_compile.t
@@ -0,0 +1,4 @@
+use strict;
+use Test::More tests => 1;
+
+BEGIN { use_ok 'URI::tag' }
View
77 t/01_tag.t
@@ -0,0 +1,77 @@
+use strict;
+use Test::Base;
+
+use URI;
+use URI::tag;
+
+plan tests => 5 * blocks;
+filters { input => 'chomp', authority => 'chomp', date => 'chomp', specific => 'chomp' };
+
+run {
+ my $block = shift;
+ my $uri = URI->new($block->input);
+ isa_ok $uri, 'URI::tag';
+ is $uri->authority, $block->authority, "authority is " . $block->authority;
+ is $uri->date, $block->date, "date is " . $block->date;
+ is $uri->specific, $block->specific, "specific is " . $block->specific;
+
+ # build new URI
+ $uri = URI->new("tag:");
+ $uri->authority($block->authority);
+ $uri->date($block->date);
+ $uri->specific($block->specific);
+
+ is $uri->as_string, $block->input, $block->input;
+}
+
+__END__
+
+===
+--- input
+tag:timothy@hpl.hp.com,2001:web/externalHome
+--- authority
+timothy@hpl.hp.com
+--- date
+2001
+--- specific
+web/externalHome
+
+===
+--- input
+tag:sandro@w3.org,2004-05:Sandro
+--- authority
+sandro@w3.org
+--- date
+2004-05
+--- specific
+Sandro
+
+===
+--- input
+tag:my-ids.com,2001-09-15:TimKindberg:presentations:UBath2004-05-19
+--- authority
+my-ids.com
+--- date
+2001-09-15
+--- specific
+TimKindberg:presentations:UBath2004-05-19
+
+===
+--- input
+tag:blogger.com,1999:blog-555
+--- authority
+blogger.com
+--- date
+1999
+--- specific
+blog-555
+
+===
+--- input
+tag:yaml.org,2002:int
+--- authority
+yaml.org
+--- date
+2002
+--- specific
+int
View
4 t/99_pod.t
@@ -0,0 +1,4 @@
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
Please sign in to comment.
Something went wrong with that request. Please try again.