Context Navigation

← Previous Change
Next Change →

Changeset 7441 for lang/perl/URI-Platonic/trunk

Timestamp:

03/04/08 02:12:17 (5 years ago)

Author:

masaki

Message:

lang/perl/URI-Platonic: Decorator として動作するようにしてみた

Location:

lang/perl/URI-Platonic/trunk

Files:

: 1 added
: 6 modified

MANIFEST (modified) (1 diff)
Makefile.PL (modified) (1 diff)
lib/URI/Platonic.pm (modified) (3 diffs)
t/01_distinct.t (modified) (1 diff)
t/02_platonic.t (modified) (1 diff)
t/03_invalid.t (modified) (1 diff)
t/04_autoload.t (added)

Legend:

: Unmodified
: Added
: Removed

lang/perl/URI-Platonic/trunk/MANIFEST

r7070	r7441
27	27	t/02_platonic.t
28	28	t/03_invalid.t
	29	t/04_autoload.t

lang/perl/URI-Platonic/trunk/Makefile.PL

r7070	r7441
4	4
5	5	requires('URI');
	6	requires('Class::Accessor::Fast');
	7	requires('Scalar::Util');
6	8
7	9	build_requires('Test::More');

lang/perl/URI-Platonic/trunk/lib/URI/Platonic.pm

r7070	r7441
3	3	use strict;
4	4	use warnings;
5		use URI::http;
	5	use base 'Class::Accessor::Fast';
	6	use overload '""' => \&as_string, fallback => 1;
	7	use Scalar::Util qw(blessed);
	8	use URI;
6	9
7	10	our $VERSION = '0.01';
8	11
9		{
10		package # hide from PAUSE
11		URI::http;
	12	__PACKAGE__->mk_accessors(qw( extension uri ));
12	13
13		~~sub platonize~~ {
14		~~my $self = shift~~;
	14	sub new {
	15	my ($class, $uri) = @_;
15	16
16		my $platonic = $self->clone;
17		$platonic->path($self->platonic_path);
18		$platonic;
	17	my $self = $class->SUPER::new({ uri => blessed($uri) ? $uri->clone : URI->new($uri) });
	18
	19	my $path = $self->uri->path;
	20	if ($path =~ m![^/]+\.([^/\.]+)$!) {
	21	$self->extension($1);
	22	$path =~ s/\.$1$//;
	23	$self->uri->path($path);
19	24	}
20	25
21		sub platonic_path {
22		my $self = shift;
23		$self->_platonic_accessor(path => @_);
	26	$self;
	27	}
	28
	29	sub clone {
	30	my $self = shift;
	31	my $class = ref $self \|\| $self;
	32	return $class->new($self->distinct);
	33	}
	34
	35	sub distinct {
	36	my $self = shift;
	37
	38	my $uri = $self->uri->clone;
	39	if ($self->extension) {
	40	$uri->path(join '.', $uri->path, $self->extension);
24	41	}
	42	$uri;
	43	}
25	44
26		sub extension {
27		my $self = shift;
28		$self->_platonic_accessor(extension => @_);
	45	our $AUTOLOAD;
	46	sub AUTOLOAD {
	47	my $self = shift;
	48
	49	my ($class, $method) = $AUTOLOAD =~ /^(.+)::([^:]+)$/;
	50
	51	if ($self->uri->can($method)) {
	52	return $self->uri->$method(@_);
29	53	}
30
31		sub _platonic_accessor {
32		my $self = shift;
33		my ($name, $value) = @_;
34
35		if (defined $value) {
36		my $parts = $self->_platonic_parts;
37		$parts->{$name} = $value;
38
39		my $path = $parts->{path};
40		$path .= ".$parts->{extension}" if $parts->{extension};
41		$self->path($path);
42		}
43
44		$self->_platonic_parts->{$name};
45		}
46
47		sub _platonic_parts {
48		my $self = shift;
49
50		my ($path, $extension) = ($self->path, '');
51		if ($path =~ m![^/]+\.([^/\.]+)$!) {
52		$extension = $1;
53		$path =~ s/\.$1//;
54		}
55		return +{ path => $path, extension => $extension };
	54	else {
	55	require Carp;
	56	Carp::croak(qq/Can't locate object method "$method" via package "$class"/);
56	57	}
57	58	}
	59
	60	sub DESTROY {}
58	61
59	62	1;
…	…
61	64	=head1 NAME
62	65
63		URI::Platonic - ~~platonic and distinct URIs~~
	66	URI::Platonic - Platonic URI decorator
64	67
65	68	=head1 SYNOPSIS
…	…
69	72
70	73	my $uri = URI->new("http://example.com/path/to/resource.html");
71		$uri->platonize; # "http://example.com/path/to/resource" (URI object)
72		$uri->platonic_path; # "/path/to/resource"
73		$uri->extension; # "html"
74		$uri->as_string; # "http://example.com/path/to/resource.html"
	74	my $platonic = URI::Platonic->new($uri);
75	75
76		$~~uri->extension('xml');~~
77		$~~uri->platonic_path; # "/path/to/resource~~"
78		$~~uri->as_string; # "http://example.com/path/to/resource.xml~~"
	76	$platonic->path; # "/path/to/resource"
	77	$platonic->extension; # "html"
	78	$platonic->as_string; # "http://example.com/path/to/resource"
79	79
80		$uri->platonic_path('/path/to/another');
81		$uri->platonize; # "http://example.com/path/to/another" (URI object)
82		$uri->extension; # "xml"
83		$uri->as_string; # "http://example.com/path/to/another.xml"
	80	$platonic->extension('xml');
	81	$platonic->path; # "/path/to/resource"
	82	$platonic->as_string; # "http://example.com/path/to/resource"
	83	$platonic->distinct; # "http://example.com/path/to/resource.xml" (URI object)
	84
	85	$platonic->path('/path/to/another');
	86	$platonic->extension; # "xml"
	87	$platonic->as_string; # "http://example.com/path/to/another"
	88	$platonic->distinct; # "http://example.com/path/to/another.xml" (URI object)
84	89
85	90	=head1 DESCRIPTION
86	91
87		URI::Platonic ~~defines helper methods for "platonic" and "d~~istinct" URIs,
	92	URI::Platonic is decorator for "Platonic" and "Distinct" URIs,
88	93	described in RESTful Web Services.
89	94
90	95	=head1 METHODS
91	96
92		=~~head2 platonize~~
	97	=over 4
93	98
94		Returns a platonic URI object.
	99	=item $platonic = URI::Platonic->new($uri)
95	100
96		=head2 platonic_path([ $path ])
	101	Constructs a new L<URI::Platonic> object.
97	102
98		Gets/Sets path for a platonic URI.
	103	=item $platonic->path([ $path ])
99	104
100		=head2 extension([ $extension ])
	105	Gets/Sets path for a "Platonic" URI.
101	106
102		Gets/Sets extension for a distinct URI.
	107	=item $platonic->extension([ $extension ])
	108
	109	Gets/Sets extension for a "Distinct" URI.
	110
	111	=item $platonic->distinct
	112
	113	Returns a "Distinct" L<URI> object.
	114
	115	=item $platonic->as_string
	116
	117	Returns a "Platonic" URI plain string.
	118
	119	=item $platonic->clone
	120
	121	Returns a copy of the $platonic.
	122
	123	=back
103	124
104	125	=head1 AUTHOR

lang/perl/URI-Platonic/trunk/t/01_distinct.t

r7070	r7441
4	4	use URI::Platonic;
5	5
6		plan tests => 12;
	6	plan tests => 13;
7	7
8		my $uri = URI->new('http://example.com/path/to/resource.html');
9		is($uri->platonic_path, '/path/to/resource');
	8	my $orig = URI->new('http://example.com/path/to/resource.html');
	9	my $uri = URI::Platonic->new($orig);
	10
	11	is($uri->path, '/path/to/resource');
10	12	is($uri->extension, 'html');
11		is($uri->~~platonize~~, 'http://example.com/path/to/resource');
12		is($uri, 'http://example.com/path/to/resource.html');
	13	is($uri->as_string, 'http://example.com/path/to/resource');
	14	is($uri->distinct, 'http://example.com/path/to/resource.html');
13	15
14	16	$uri->extension('jpg');
15		is($uri->p~~latonic_p~~ath, '/path/to/resource');
	17	is($uri->path, '/path/to/resource');
16	18	is($uri->extension, 'jpg');
17		is($uri->~~platonize~~, 'http://example.com/path/to/resource');
18		is($uri, 'http://example.com/path/to/resource.jpg');
	19	is($uri->as_string, 'http://example.com/path/to/resource');
	20	is($uri->distinct, 'http://example.com/path/to/resource.jpg');
19	21
20		$uri->p~~latonic_p~~ath('/path/to/another');
21		is($uri->p~~latonic_p~~ath, '/path/to/another');
	22	$uri->path('/path/to/another');
	23	is($uri->path, '/path/to/another');
22	24	is($uri->extension, 'jpg');
23		is($uri->platonize, 'http://example.com/path/to/another');
24		is($uri, 'http://example.com/path/to/another.jpg');
	25	is($uri->as_string, 'http://example.com/path/to/another');
	26	is($uri->distinct, 'http://example.com/path/to/another.jpg');
	27
	28	is($uri, $uri->as_string);

lang/perl/URI-Platonic/trunk/t/02_platonic.t

r7070	r7441
6	6	plan tests => 12;
7	7
8		my $uri = URI->new('http://example.com/path/to/resource');
9		is($uri->platonic_path, '/path/to/resource');
10		is($uri->extension, '');
11		is($uri->platonize, 'http://example.com/path/to/resource');
12		is($uri, 'http://example.com/path/to/resource');
	8	my $orig = URI->new('http://example.com/path/to/resource');
	9	my $uri = URI::Platonic->new($orig);
13	10
14		$uri->platonic_path('/path/to/another');
15		is($uri->platonic_path, '/path/to/another');
16		is($uri->extension, '');
17		is($uri->platonize, 'http://example.com/path/to/another');
18		is($uri, 'http://example.com/path/to/another');
	11	is($uri->path, '/path/to/resource');
	12	is($uri->extension, undef);
	13	is($uri->as_string, 'http://example.com/path/to/resource');
	14	is($uri->distinct, 'http://example.com/path/to/resource');
	15
	16	$uri->path('/path/to/another');
	17	is($uri->path, '/path/to/another');
	18	is($uri->extension, undef);
	19	is($uri->as_string, 'http://example.com/path/to/another');
	20	is($uri->distinct, 'http://example.com/path/to/another');
19	21
20	22	$uri->extension('xml');
21		is($uri->p~~latonic_p~~ath, '/path/to/another');
	23	is($uri->path, '/path/to/another');
22	24	is($uri->extension, 'xml');
23		is($uri->~~platonize~~, 'http://example.com/path/to/another');
24		is($uri, 'http://example.com/path/to/another.xml');
	25	is($uri->as_string, 'http://example.com/path/to/another');
	26	is($uri->distinct, 'http://example.com/path/to/another.xml');

lang/perl/URI-Platonic/trunk/t/03_invalid.t

r7070	r7441
6	6	plan tests => 8;
7	7
8		my $uri = URI->new('http://example.com/.extension');
9		is($uri->platonic_path, '/.extension');
10		is($uri->extension, '');
11		is($uri->platonize, 'http://example.com/.extension');
12		is($uri, 'http://example.com/.extension');
	8	my $orig = URI->new('http://example.com/.extension');
	9	my $uri = URI::Platonic->new($orig);
	10
	11	is($uri->path, '/.extension');
	12	is($uri->extension, undef);
	13	is($uri->as_string, 'http://example.com/.extension');
	14	is($uri->distinct, 'http://example.com/.extension');
13	15
14	16	$uri->extension('jpg');
15		is($uri->p~~latonic_p~~ath, '/.extension');
	17	is($uri->path, '/.extension');
16	18	is($uri->extension, 'jpg');
17		is($uri->~~platonize~~, 'http://example.com/.extension');
18		is($uri, 'http://example.com/.extension.jpg');
	19	is($uri->as_string, 'http://example.com/.extension');
	20	is($uri->distinct, 'http://example.com/.extension.jpg');

Download in other formats: