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