Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

URI::Unprotocol

by premchai21 (Curate)
on Jun 03, 2001 at 06:20 UTC ( #85264=perlcraft: print w/replies, xml ) Need Help??

   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;

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlcraft [id://85264]
Approved by root
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others imbibing at the Monastery: (3)
As of 2022-12-04 08:06 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found

    Notices?