home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 2002 #12 / Amiga Plus CD - 2002 - No. 12.iso / Tools / Development / source-highlight-1.6.1 / tests / test.pm < prev    next >
Encoding:
Perl POD Document  |  2002-11-17  |  6.4 KB  |  238 lines
  1. # Here an extract of package MIME::Lite::HTML
  2.  
  3. package MIME::Lite::HTML;
  4.  
  5. # module MIME::Lite::HTML : Provide routine to transform a HTML page in 
  6. # a MIME::Lite mail
  7. # Copyright 2001 A.Barbet alian@alianwebserver.com.  All rights reserved.
  8.  
  9. # Revision 1.1  2002/02/07 15:58:35  bettini
  10. # added scanner for perl
  11. #
  12. # Revision 1.12  2002/01/07 20:18:53  alian
  13. # - Add replace links for frame & iframe
  14. # - Correct incorrect parsing in include_css for <LINK REL="SHORTCUT ICON">
  15. # tag. Tks to doggy@miniasp.com for idea and patch
  16. #
  17. # Revision 1.11  2001/12/13 22:42:33  alian
  18. # - Correct a bug with relative anchor
  19. #
  20. # Revision 1.10  2001/11/07 10:52:43  alian
  21. # - Add feature for get restricted url. Add LoginDetails parameter for that
  22. # (tks to Leon.Halford@ing-barings.com for idea)
  23. # - Change error in POD doc rfc2257 => rfc2557 (tks to
  24. # justin.zaglio@morganstanley.com)
  25. # - Correct warning when $url_html is undef
  26.  
  27. use LWP::UserAgent;
  28. use HTML::LinkExtor;
  29. use URI::URL;
  30. use MIME::Lite;
  31. use strict;
  32. use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  33.  
  34. require Exporter;
  35.  
  36. @ISA = qw(Exporter);
  37. @EXPORT = qw();
  38.  
  39. my $LOGINDETAILS;
  40.  
  41. #------------------------------------------------------------------------------
  42. # redefine get_basic_credentials
  43. #------------------------------------------------------------------------------
  44. {
  45.     package RequestAgent;
  46.     use vars qw(@ISA);
  47.     @ISA = qw(LWP::UserAgent);
  48.  
  49.     sub new
  50.     { 
  51.     my $self = LWP::UserAgent::new(@_);
  52.     $self;
  53.     }
  54.  
  55.     sub get_basic_credentials
  56.     {    
  57.       my($self, $realm, $uri) = @_;
  58.       # Use parameter of MIME-Lite-HTML, key LoginDetails
  59.       if (defined $LOGINDETAILS) { return split(':', $LOGINDETAILS, 2); } 
  60.       # Ask user on STDIN
  61.       elsif (-t) 
  62.         {
  63.         my $netloc = $uri->host_port;
  64.         print "Enter username for $realm at $netloc: ";
  65.         my $user = <STDIN>;
  66.         chomp($user);
  67.         # 403 if no user given
  68.         return (undef, undef) unless length $user;
  69.         print "Password: ";
  70.         system("stty -echo");
  71.         my $password = <STDIN>;
  72.         system("stty echo");
  73.         print "\n";  # because we disabled echo
  74.         chomp($password);
  75.         return ($user, $password);
  76.         }
  77.       # Damm we got 403 with CGI (use param LoginDetails)  ...
  78.       else { return (undef, undef) }
  79.     }
  80.   }
  81.  
  82. #------------------------------------------------------------------------------
  83. # new
  84. #------------------------------------------------------------------------------
  85. sub new
  86.   {
  87.     my $class = shift;
  88.     my $self = {};
  89.     bless $self, $class;
  90.     my %param = @_;
  91.     # Agent name
  92.     $self->{_AGENT} = new RequestAgent;
  93.     $self->{_AGENT}->agent("MIME-Lite-HTML $VERSION");
  94.     $self->{_AGENT}->from('mime-lite-html@alianwebserver.com' );
  95.     # Set debug level
  96.     if ($param{'Debug'})
  97.       {
  98.     $self->{_DEBUG} = 1;
  99.     delete $param{'Debug'};
  100.       }
  101.     # Set Login information
  102.     if ($param{'LoginDetails'})
  103.       {
  104.       $LOGINDETAILS = $param{'LoginDetails'};
  105.       delete $param{'LoginDetails'};
  106.       }
  107.     # Set type of include to do
  108.     if ($param{'IncludeType'})
  109.       {
  110.     die "IncludeType must be in 'extern', 'cid' or 'location'\n" if
  111.       ( ($param{'IncludeType'} ne 'extern') and
  112.         ($param{'IncludeType'} ne 'cid') and
  113.         ($param{'IncludeType'} ne 'location'));    
  114.     $self->{_include} = $param{'IncludeType'};
  115.     delete $param{'IncludeType'};
  116.       }
  117.     # Defaut type: use a Content-Location field
  118.     else {$self->{_include}='location';}
  119.  
  120. ## Added by Michalis@linuxmail.org to manipulate non-us mails
  121.    if ($param{'TextCharset'}) {
  122.      $self->{_textcharset}=$param{'TextCharset'};
  123.      delete $param{'TextCharset'};
  124.    }
  125.    else { $self->{_textcharset}='iso-8859-1'; }
  126.    if ($param{'HTMLCharset'}) {
  127.      $self->{_htmlcharset}=$param{'HTMLCharset'};
  128.      delete $param{'HTMLCharset'};
  129.     }
  130.    else { $self->{_htmlcharset}='iso-8859-1'; }
  131.  
  132.    if ($param{'TextEncoding'}) {
  133.      $self->{_textencoding}=$param{'TextEncoding'};
  134.      delete $param{'TextEncoding'};
  135.     }
  136.    else { $self->{_textencoding}='7bit'; }
  137.  
  138.    if ($param{'HTMLEncoding'}) {
  139.      $self->{_htmlencoding}=$param{'HTMLEncoding'};
  140.      delete $param{'HTMLEncoding'};
  141.     }
  142.    else { $self->{_htmlencoding}='quoted-printable'; }
  143. ## End. Default values remain as they were initially set.
  144. ## No need to change existing scripts if you send US-ASCII. 
  145. ## If you DON't send us-ascii, you wouldn't be able to use 
  146. ## MIME::Lite::HTML anyway :-)
  147.  
  148.     # Set proxy to use to get file
  149.     if ($param{'Proxy'})
  150.       {
  151.     $self->{_AGENT}->proxy('http',$param{'Proxy'}) ;
  152.     print "Set proxy for http : ", $param{'Proxy'},"\n" 
  153.       if ($self->{_DEBUG});
  154.     delete $param{'Proxy'};
  155.       }
  156.     # Set hash to use with template
  157.     if ($param{'HashTemplate'})
  158.       {
  159.     $param{'HashTemplate'} = ref($param{'HashTemplate'}) eq "HASH" 
  160.       ? $param{'HashTemplate'} : %{$param{'HashTemplate'}};
  161.     $self->{_HASH_TEMPLATE}= $param{'HashTemplate'};
  162.     delete $param{'HashTemplate'};
  163.       }
  164.     $self->{_param} = \%param;
  165.     # Ok I hope I known what I do ;-)
  166.     MIME::Lite->quiet(1);
  167.     return $self;
  168.   }
  169.  
  170. #------------------------------------------------------------------------------
  171. # POD Documentation
  172. #------------------------------------------------------------------------------
  173.  
  174. =head1 NAME
  175.  
  176. MIME::Lite::HTML - Provide routine to transform a HTML page in a MIME-Lite mail
  177.  
  178. =head1 SYNOPSIS
  179.  
  180.   #!/usr/bin/perl -w 
  181.   # A cgi program that do "Mail this page to a friend";
  182.   # Call this script like this :
  183.   # script.cgi?email=myfriend@isp.com&url=http://www.go.com
  184.   use strict;
  185.   use CGI qw/:standard/;
  186.   use CGI::Carp qw/fatalsToBrowser/;
  187.   use MIME::Lite::HTML;
  188.   
  189.   my $mailHTML = new MIME::Lite::HTML
  190.      From     => 'MIME-Lite@alianwebserver.com',
  191.      To       => param('email'),
  192.      Subject => 'Your url: '.param('url');
  193.   
  194.   my $MIMEmail = $mailHTML->parse(param('url'));
  195.   $MIMEmail->send; # or for win user : $mail->send_by_smtp('smtp.fai.com');
  196.   print header,"Mail envoye (", param('url'), " to ", param('email'),")<br>\n";
  197.  
  198. =head1 DESCRIPTION
  199.  
  200. This module is a Perl mail client interface for sending message that 
  201. support HTML format and build them for you..
  202. This module provide routine to transform a HTML page in MIME::Lite mail.
  203. So you need this module to use MIME-Lite-HTML possibilities
  204.  
  205. =head2 What's happen ?
  206.  
  207. The job done is:
  208.  
  209. =over
  210.  
  211. =item *
  212.  
  213. Get the file (LWP) if needed
  214.  
  215. =item *
  216.  
  217. Parse page to find include images (gif, jpg, flash)
  218.  
  219. =item *
  220.  
  221. Attach them to mail with adequat header if asked (default)
  222.  
  223. =item *
  224.  
  225. Include external CSS,Javascript file
  226.  
  227. =item *
  228.  
  229. Replace relative url with absolute one
  230.  
  231. =item *
  232.  
  233. Build the final MIME-Lite object with each part found
  234.  
  235. =back
  236.  
  237. =cut
  238.