home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _00ff369a0b149d6a7e7ad774e2c7933e < prev    next >
Encoding:
Text File  |  2000-03-15  |  4.3 KB  |  165 lines
  1. #
  2. # $Id: mailto.pm,v 1.9 1999/03/19 21:00:13 gisle Exp $
  3. #
  4. # This module implements the mailto protocol.  It is just a simple
  5. # frontend to the Unix sendmail program except on MacOS, where it uses
  6. # Mail::Internet.
  7.  
  8. package LWP::Protocol::mailto;
  9.  
  10. require LWP::Protocol;
  11. require HTTP::Request;
  12. require HTTP::Response;
  13. require HTTP::Status;
  14.  
  15. use Carp;
  16. use strict;
  17. use vars qw(@ISA $SENDMAIL);
  18.  
  19. @ISA = qw(LWP::Protocol);
  20.  
  21. $SENDMAIL ||= "/usr/lib/sendmail";
  22.  
  23. sub request
  24. {
  25.     my($self, $request, $proxy, $arg, $size) = @_;
  26.  
  27.     my ($mail, $addr) if $^O eq "MacOS";
  28.     my @text = () if $^O eq "MacOS";
  29.  
  30.     # check proxy
  31.     if (defined $proxy)
  32.     {
  33.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  34.                   'You can not proxy with mail';
  35.     }
  36.  
  37.     # check method
  38.     my $method = $request->method;
  39.  
  40.     if ($method ne 'POST') {
  41.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  42.                   'Library does not allow method ' .
  43.                   "$method for 'mailto:' URLs";
  44.     }
  45.  
  46.     # check url
  47.     my $url = $request->url;
  48.  
  49.     my $scheme = $url->scheme;
  50.     if ($scheme ne 'mailto') {
  51.     return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  52.                   "LWP::file::request called for '$scheme'";
  53.     }
  54.     if ($^O eq "MacOS") {
  55.     eval {
  56.         require Mail::Internet;
  57.     };
  58.     if($@) {
  59.         return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  60.                    "You don't have MailTools installed";
  61.     }
  62.     unless ($ENV{SMTPHOSTS}) {
  63.         return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  64.                    "You don't have SMTPHOSTS defined";
  65.     }
  66.     } else {
  67.     unless (-x $SENDMAIL) {
  68.         return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  69.                    "You don't have $SENDMAIL";
  70.     }
  71.     }
  72.     if ($^O eq "MacOS") {
  73.         $mail = Mail::Internet->new or
  74.         return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  75.         "Can't get a Mail::Internet object";
  76.     } else {
  77.     open(SENDMAIL, "| $SENDMAIL -oi -t") or
  78.         return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  79.                    "Can't run $SENDMAIL: $!";
  80.     }
  81.     if ($^O eq "MacOS") {
  82.     $addr = $url->encoded822addr;
  83.     } else {
  84.     $request = $request->clone;  # we modify a copy
  85.     my @h = $url->headers;  # URL headers override those in the request
  86.     while (@h) {
  87.         my $k = shift @h;
  88.         my $v = shift @h;
  89.         next unless defined $v;
  90.         if (lc($k) eq "body") {
  91.         $request->content($v);
  92.         } else {
  93.         $request->push_header($k => $v);
  94.         }
  95.     }
  96.     }
  97.     if ($^O eq "MacOS") {
  98.     $mail->add(To => $addr);
  99.     $mail->add(split(/[:\n]/,$request->headers_as_string));
  100.     } else {
  101.     print SENDMAIL $request->headers_as_string;
  102.     print SENDMAIL "\n";
  103.     }
  104.     my $content = $request->content;
  105.     if (defined $content) {
  106.     my $contRef = ref($content) ? $content : \$content;
  107.     if (ref($contRef) eq 'SCALAR') {
  108.         if ($^O eq "MacOS") {
  109.         @text = split("\n",$$contRef);
  110.         foreach (@text) {
  111.             $_ .= "\n";
  112.         }
  113.         } else {
  114.         print SENDMAIL $$contRef;
  115.         }
  116.  
  117.     } elsif (ref($contRef) eq 'CODE') {
  118.         # Callback provides data
  119.         my $d;
  120.         if ($^O eq "MacOS") {
  121.         my $stuff = "";
  122.         while (length($d = &$contRef)) {
  123.             $stuff .= $d;
  124.         }
  125.         @text = split("\n",$stuff);
  126.         foreach (@text) {
  127.             $_ .= "\n";
  128.         }
  129.         } else {
  130.         print SENDMAIL $d;
  131.         }
  132.     }
  133.     }
  134.     if ($^O eq "MacOS") {
  135.     $mail->body(\@text);
  136.     unless ($mail->smtpsend) {
  137.         return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  138.                        "Mail::Internet->smtpsend unable to send message to <$addr>");
  139.     }
  140.     } else {
  141.     unless (close(SENDMAIL)) {
  142.         my $err = $! ? "$!" : "Exit status $?";
  143.         return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  144.                        "$SENDMAIL: $err");
  145.     }
  146.     }
  147.  
  148.  
  149.     my $response = HTTP::Response->new(&HTTP::Status::RC_ACCEPTED,
  150.                        "Mail accepted");
  151.     $response->header('Content-Type', 'text/plain');
  152.     if ($^O eq "MacOS") {
  153.     $response->header('Server' => "Mail::Internet $Mail::Internet::VERSION");
  154.     $response->content("Message sent to <$addr>\n");
  155.     } else {
  156.     $response->header('Server' => $SENDMAIL);
  157.     my $to = $request->header("To");
  158.     $response->content("Message sent to <$to>\n");
  159.     }
  160.  
  161.     return $response;
  162. }
  163.  
  164. 1;
  165.