home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl5 / auto / RPC / XML / Server / copy_methods.al < prev    next >
Encoding:
Text File  |  2008-11-04  |  1.9 KB  |  77 lines
  1. # NOTE: Derived from blib/lib/RPC/XML/Server.pm.
  2. # Changes made here will be lost when autosplit is run again.
  3. # See AutoSplit.pm.
  4. package RPC::XML::Server;
  5.  
  6. #line 2016 "blib/lib/RPC/XML/Server.pm (autosplit into blib/lib/auto/RPC/XML/Server/copy_methods.al)"
  7. sub copy_methods
  8. {
  9.     my $self    = shift;
  10.     my $src_srv = shift;
  11.     my @names   = shift;
  12.  
  13.     my ($me, $pkg, %tmp, @tmp, $tmp, $meth, @list, @missing);
  14.  
  15.     $me = ref($self) . '::copy_methods';
  16.     $pkg = __PACKAGE__; # So it can go inside quoted strings
  17.  
  18.     return "$me: First arg not derived from $pkg, cannot copy"
  19.         unless ((ref $src_srv) && (UNIVERSAL::isa($src_srv, $pkg)));
  20.     return "$me: Must specify at least one method name/regex for copying"
  21.         unless @names;
  22.  
  23.     #
  24.     # Scan @names for any regez objects, and if found insert the matches into
  25.     # the list.
  26.     #
  27.     # Only do this once:
  28.     #
  29.     @tmp = keys %{$src_srv->{__method_table}};
  30.     for $tmp (@names)
  31.     {
  32.         if (ref($names[$tmp]) eq 'Regexp')
  33.         {
  34.             $tmp{$_}++ for (grep($_ =~ $tmp, @tmp));
  35.         }
  36.         else
  37.         {
  38.             $tmp{$tmp}++;
  39.         }
  40.     }
  41.     # This has the benefit of trimming any redundancies caused by regex's
  42.     @names = keys %tmp;
  43.  
  44.     #
  45.     # Note that the method clones are saved until we've verified all of them.
  46.     # If we have to return a failure message, I don't want to leave a half-
  47.     # finished job or have to go back and undo (n-1) additions because of one
  48.     # failure.
  49.     #
  50.     for (@names)
  51.     {
  52.         $meth = $src_srv->get_method($_);
  53.         if (ref $meth)
  54.         {
  55.             push(@list, $meth->clone);
  56.         }
  57.         else
  58.         {
  59.             push(@missing, $_);
  60.         }
  61.     }
  62.  
  63.     if (@missing)
  64.     {
  65.         return "$me: One or more methods not found on source object: @missing";
  66.     }
  67.     else
  68.     {
  69.         $self->add_method($_) for (@list);
  70.     }
  71.  
  72.     $self;
  73. }
  74.  
  75. # end of RPC::XML::Server::copy_methods
  76. 1;
  77.