home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _f4c33016650085de92379a5047332452 < prev    next >
Encoding:
Text File  |  2004-06-01  |  1.8 KB  |  87 lines
  1. #
  2. # Written by Ryan Kereliuk <ryker@ryker.org>.  This file may be
  3. # distributed under the same terms as Perl itself.
  4. #
  5. # The RFC 3261 sip URI is <scheme>:<authority>;<params>?<query>.
  6. #
  7.  
  8. package URI::sip;
  9.  
  10. require URI::_server;
  11. require URI::_userpass;
  12. @ISA=qw(URI::_server URI::_userpass);
  13.  
  14. use strict;
  15. use vars qw(@ISA $VERSION);
  16. use URI::Escape qw(uri_unescape);
  17.  
  18. $VERSION = "0.10";
  19.  
  20. sub default_port { 5060 }
  21.  
  22. sub authority
  23. {
  24.     my $self = shift;
  25.     $$self =~ m,^($URI::scheme_re:)?([^;?]*)(.*)$,os or die;
  26.     my $old = $2;
  27.  
  28.     if (@_) {
  29.         my $auth = shift;
  30.         $$self = defined($1) ? $1 : "";
  31.         my $rest = $3;
  32.         if (defined $auth) {
  33.             $auth =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go;
  34.             $$self .= "$auth";
  35.         }
  36.         $$self .= $rest;
  37.     }
  38.     $old;
  39. }
  40.  
  41. sub params_form
  42. {
  43.     my $self = shift;
  44.     $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
  45.     my $paramstr = $3;
  46.  
  47.     if (@_) {
  48.         my @args = @_; 
  49.         $$self = $1 . $2;
  50.         my $rest = $4;
  51.     my @new;
  52.     for (my $i=0; $i < @args; $i += 2) {
  53.         push(@new, "$args[$i]=$args[$i+1]");
  54.     }
  55.     $paramstr = join(";", @new);
  56.     $$self .= ";" . $paramstr . $rest;
  57.     }
  58.     $paramstr =~ s/^;//o;
  59.     return split(/[;=]/, $paramstr);
  60. }
  61.  
  62. sub params
  63. {
  64.     my $self = shift;
  65.     $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
  66.     my $paramstr = $3;
  67.  
  68.     if (@_) {
  69.         my $new = shift; 
  70.         $$self = $1 . $2;
  71.         my $rest = $4;
  72.     $$self .= $paramstr . $rest;
  73.     }
  74.     $paramstr =~ s/^;//o;
  75.     return $paramstr;
  76. }
  77.  
  78. # Inherited methods that make no sense for a SIP URI.
  79. sub path {};
  80. sub path_query {};
  81. sub path_segments {};
  82. sub abs {};
  83. sub rel {};
  84. sub query_keywords {};
  85.  
  86. 1;
  87.