/extras/perl/site_perl/LWP/Protocol/mailto.pm

http://github.com/perigrin/android-scripting-environment-perl · Perl · 183 lines · 159 code · 17 blank · 7 comment · 30 complexity · 66ff19172bf66fa106a6602ec358b4a7 MD5 · raw file

  1. package LWP::Protocol::mailto;
  2. # This module implements the mailto protocol. It is just a simple
  3. # frontend to the Unix sendmail program except on MacOS, where it uses
  4. # Mail::Internet.
  5. require LWP::Protocol;
  6. require HTTP::Request;
  7. require HTTP::Response;
  8. require HTTP::Status;
  9. use Carp;
  10. use strict;
  11. use vars qw(@ISA $SENDMAIL);
  12. @ISA = qw(LWP::Protocol);
  13. unless ($SENDMAIL = $ENV{SENDMAIL}) {
  14. for my $sm (qw(/usr/sbin/sendmail
  15. /usr/lib/sendmail
  16. /usr/ucblib/sendmail
  17. ))
  18. {
  19. if (-x $sm) {
  20. $SENDMAIL = $sm;
  21. last;
  22. }
  23. }
  24. die "Can't find the 'sendmail' program" unless $SENDMAIL;
  25. }
  26. sub request
  27. {
  28. my($self, $request, $proxy, $arg, $size) = @_;
  29. my ($mail, $addr) if $^O eq "MacOS";
  30. my @text = () if $^O eq "MacOS";
  31. # check proxy
  32. if (defined $proxy)
  33. {
  34. return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  35. 'You can not proxy with mail';
  36. }
  37. # check method
  38. my $method = $request->method;
  39. if ($method ne 'POST') {
  40. return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  41. 'Library does not allow method ' .
  42. "$method for 'mailto:' URLs";
  43. }
  44. # check url
  45. my $url = $request->uri;
  46. my $scheme = $url->scheme;
  47. if ($scheme ne 'mailto') {
  48. return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  49. "LWP::Protocol::mailto::request called for '$scheme'";
  50. }
  51. if ($^O eq "MacOS") {
  52. eval {
  53. require Mail::Internet;
  54. };
  55. if($@) {
  56. return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  57. "You don't have MailTools installed";
  58. }
  59. unless ($ENV{SMTPHOSTS}) {
  60. return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  61. "You don't have SMTPHOSTS defined";
  62. }
  63. }
  64. else {
  65. unless (-x $SENDMAIL) {
  66. return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  67. "You don't have $SENDMAIL";
  68. }
  69. }
  70. if ($^O eq "MacOS") {
  71. $mail = Mail::Internet->new or
  72. return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  73. "Can't get a Mail::Internet object";
  74. }
  75. else {
  76. open(SENDMAIL, "| $SENDMAIL -oi -t") or
  77. return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  78. "Can't run $SENDMAIL: $!";
  79. }
  80. if ($^O eq "MacOS") {
  81. $addr = $url->encoded822addr;
  82. }
  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. }
  93. else {
  94. $request->push_header($k => $v);
  95. }
  96. }
  97. }
  98. if ($^O eq "MacOS") {
  99. $mail->add(To => $addr);
  100. $mail->add(split(/[:\n]/,$request->headers_as_string));
  101. }
  102. else {
  103. print SENDMAIL $request->headers_as_string;
  104. print SENDMAIL "\n";
  105. }
  106. my $content = $request->content;
  107. if (defined $content) {
  108. my $contRef = ref($content) ? $content : \$content;
  109. if (ref($contRef) eq 'SCALAR') {
  110. if ($^O eq "MacOS") {
  111. @text = split("\n",$$contRef);
  112. foreach (@text) {
  113. $_ .= "\n";
  114. }
  115. }
  116. else {
  117. print SENDMAIL $$contRef;
  118. }
  119. }
  120. elsif (ref($contRef) eq 'CODE') {
  121. # Callback provides data
  122. my $d;
  123. if ($^O eq "MacOS") {
  124. my $stuff = "";
  125. while (length($d = &$contRef)) {
  126. $stuff .= $d;
  127. }
  128. @text = split("\n",$stuff);
  129. foreach (@text) {
  130. $_ .= "\n";
  131. }
  132. }
  133. else {
  134. print SENDMAIL $d;
  135. }
  136. }
  137. }
  138. if ($^O eq "MacOS") {
  139. $mail->body(\@text);
  140. unless ($mail->smtpsend) {
  141. return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  142. "Mail::Internet->smtpsend unable to send message to <$addr>");
  143. }
  144. }
  145. else {
  146. unless (close(SENDMAIL)) {
  147. my $err = $! ? "$!" : "Exit status $?";
  148. return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  149. "$SENDMAIL: $err");
  150. }
  151. }
  152. my $response = HTTP::Response->new(&HTTP::Status::RC_ACCEPTED,
  153. "Mail accepted");
  154. $response->header('Content-Type', 'text/plain');
  155. if ($^O eq "MacOS") {
  156. $response->header('Server' => "Mail::Internet $Mail::Internet::VERSION");
  157. $response->content("Message sent to <$addr>\n");
  158. }
  159. else {
  160. $response->header('Server' => $SENDMAIL);
  161. my $to = $request->header("To");
  162. $response->content("Message sent to <$to>\n");
  163. }
  164. return $response;
  165. }
  166. 1;