1: # In regard of the google://, the id://, and the recent request for dict://,
2: # I offer you: URI::Unprotocol!
3:
4: package URI::Unprotocol;
5: # URI::Unprotocol
6: # Copyright (C) 2001 Drake Wilson
7: # This program is free software; you can redistribute it and/or
8: # modify it under the terms of the GNU General Public License
9: # as published by the Free Software Foundation; either version 2
10: # of the License, or (at your option) any later version.
11: #
12: # This program is distributed in the hope that it will be useful,
13: # but WITHOUT ANY WARRANTY; without even the implied warranty of
14: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: # GNU General Public License for more details.
16: #
17: # If you wish to receive a copy of the GNU General Public License, write to the Free Software
18: # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA, or see
19: # <http://www.gnu.org/copyleft/gpl.html>.
20: #
21: # You can contact me by e-mail at (backward) moc.toofgib@12iahcmerp.
22:
23: =head1 NAME
24:
25: URI::Unprotocol
26:
27: =head1 SYNOPSIS
28:
29: use URI::Unprotocol qw/google e2/;
30: URI::Unprotocol::apply ("google://stuff");
31: URI::Unprotocol::setwrap('',1);
32: URI::Unprotocol::add ("somesite", sub { "http://somesite.com/$_.html" } );
33: URI::Unprotocol::modify ("somesite", sub { "http://somesite.net/$_.cfm" } );
34: URI::Unprotocol::remove ("somesite");
35:
36: =head1 DESCRIPTION
37:
38: URI::Unprotocol was created for sites such as Perlmonks which need / want / could use
39: "unprotocols", that is, foreign protocols that actually map onto known protocols.
40: The package contains the following items:
41:
42: =over 4
43:
44: =item apply (string)
45:
46: Applies the current set of Unprotocols to a given string, which must
47: be a valid URI. Returns a converted string if an Unprotocol with that
48: name exists, otherwise returns URI-string unconverted.
49:
50: =item setwrap (protocol or undef, setting), iswrap (protocol or undef)
51:
52: Sets or gets the wrappering value for either a given unprotocol, or
53: the default for newly defined unprotocols. When unwrappered, an
54: unprotocol sub will receive a URI object in $_ containing the URI. When
55: wrappered, an unprotocol sub will receive a string in $_ containing the
56: URI minus the leading unprotocol name. The default is currently
57: stored in $Wrap.
58:
59: =item add (protocol, sub)
60:
61: Adds a protocol to the current set with the specified sub. See
62: L</setwrap>.
63:
64: =item remove (protocol)
65:
66: Self-explanatory, I hope.
67:
68: =item modify (protocol, sub)
69:
70: Sets the sub for the protocol to the specified sub. See
71: L</setwrap>.
72:
73: =item %standard
74:
75: (internal) The set of unprotocols that can be imported from the
76: use line.
77:
78: =item %list
79:
80: (internal) The current set of unprotocols.
81:
82: =back
83:
84: =head1 SEE ALSO
85:
86: L<URI>
87:
88: =cut
89:
90: use Carp;
91: use URI;
92: use vars qw/%list %standard $Wrap/;
93:
94: %standard = (
95: google => [ sub { "http://www.google.com/search?q=$_" }, 1 ],
96: pm => [ sub { "http://www.perlmonks.org/index.pl?node=$_" }, 1 ],
97: pmid => [ sub { "http://www.perlmonks.org/index.pl?id=$_" }, 1 ],
98: e2 => [ sub { "http://www.everything2.com/index.pl?node=$_" }, 1 ],
99: e2id => [ sub { "http://www.everything2.com/index.pl?node_id=$_" }, 1 ],
100: altavista => [ sub { "http://www.altavista.com/sites/search/web?q=$_&kl=XX&pg=q" },
101: 1 ],
102: dict => [ sub { "http://www.dictionary.com/cgi-bin/dict.pl?term=$_" }, 1 ],
103: );
104: %list = ();
105: $Wrap = 0;
106:
107: sub import
108: {
109: foreach (@_)
110: {
111: if ($_ eq ':all')
112: {
113: %list = (%list, %standard);
114: last;
115: }
116: $list{$_} = $standard{$_};
117: }
118: }
119:
120: sub add ($&) { $list{$_[0]}=[$_[1], $Wrap] }
121: sub modify($&) { $list{$_[0]}->[0] = $_[1] }
122: sub remove($ ) { delete $list{$_[0]}}
123:
124: sub iswrap($ )
125: {
126: return $Wrap if (!$_[0]);
127: return $list{$_[0]}->[1] if (exists $list{$_[0]});
128: return undef;
129: }
130:
131: sub setwrap($$)
132: {
133: $Wrap = $_[1] if (!$_[0]);
134: $list{$_[0]}->[1] = $_[1] if (exists $list{$_[0]});
135: }
136:
137: sub apply($ )
138: {
139: if (my $uri = URI->new($_[0]))
140: {
141: my $sch = $uri->scheme;
142: my $qsch = quotemeta($sch);
143: if (exists $list{$sch})
144: {
145: my $iru = $uri;
146: $list{$sch}->[1] && do
147: {
148: $iru = "$iru";
149: $iru =~ s/^$qsch(?:\:\/{0,3})?//;
150: };
151: for ($iru)
152: {
153: return (($list{$sch}->[0])->());
154: }
155: }
156: return $_[0];
157: }
158: croak "Bad URI";
159: }
160:
161: 1;