001: # Here an extract of package MIME::Lite::HTML
002: 
003: package MIME::Lite::HTML;
004: 
005: # module MIME::Lite::HTML : Provide routine to transform a HTML page in 
006: # a MIME::Lite mail
007: # Copyright 2001 A.Barbet alian@alianwebserver.com. All rights reserved.
008: 
009: # Revision 1.1 2002年02月07日 15:58:35 bettini
010: # added scanner for perl
011: #
012: # Revision 1.12 2002年01月07日 20:18:53 alian
013: # - Add replace links for frame & iframe
014: # - Correct incorrect parsing in include_css for <LINK REL="SHORTCUT ICON">
015: # tag. Tks to doggy@miniasp.com for idea and patch
016: #
017: # Revision 1.11 2001年12月13日 22:42:33 alian
018: # - Correct a bug with relative anchor
019: #
020: # Revision 1.10 2001年11月07日 10:52:43 alian
021: # - Add feature for get restricted url. Add LoginDetails parameter for that
022: # (tks to Leon.Halford@ing-barings.com for idea)
023: # - Change error in POD doc rfc2257 => rfc2557 (tks to
024: # justin.zaglio@morganstanley.com)
025: # - Correct warning when $url_html is undef
026: 
027: use LWP::UserAgent;
028: use HTML::LinkExtor;
029: use URI::URL;
030: use MIME::Lite;
031: use strict;
032: use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
033: 
034: require Exporter;
035: 
036: @ISA = qw(Exporter);
037: @EXPORT = qw();
038: 
039: my $LOGINDETAILS;
040: 
041: #------------------------------------------------------------------------------
042: # redefine get_basic_credentials
043: #------------------------------------------------------------------------------
044: {
045: package RequestAgent;
046: use vars qw(@ISA);
047: @ISA = qw(LWP::UserAgent);
048: 
049: sub new
050: { 
051: my $self = LWP::UserAgent::new(@_);
052: $self;
053: }
054: 
055: sub get_basic_credentials
056: { 
057: my($self, $realm, $uri) = @_;
058: # Use parameter of MIME-Lite-HTML, key LoginDetails
059: if (defined $LOGINDETAILS) { return split(':', $LOGINDETAILS, 2); } 
060: # Ask user on STDIN
061: elsif (-t) 
062: {
063: my $netloc = $uri->host_port;
064: print "Enter username for $realm at $netloc: ";
065: my $user = <STDIN>;
066: chomp($user);
067: # 403 if no user given
068: return (undef, undef) unless length $user;
069: print "Password: ";
070: system("stty -echo");
071: my $password = <STDIN>;
072: system("stty echo");
073: print "\n"; # because we disabled echo
074: chomp($password);
075: return ($user, $password);
076: }
077: # Damm we got 403 with CGI (use param LoginDetails) ...
078: else { return (undef, undef) }
079: }
080: }
081: 
082: #------------------------------------------------------------------------------
083: # new
084: #------------------------------------------------------------------------------
085: sub new
086: {
087: my $class = shift;
088: my $self = {};
089: bless $self, $class;
090: my %param = @_;
091: # Agent name
092: $self->{_AGENT} = new RequestAgent;
093: $self->{_AGENT}->agent("MIME-Lite-HTML $VERSION");
094: $self->{_AGENT}->from('mime-lite-html@alianwebserver.com' );
095: # Set debug level
096: if ($param{'Debug'})
097: {
098: $self->{_DEBUG} = 1;
099: 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: 
239: ## the next one is just to see if =cut is recognized
240: sub foo
241: {
242: my $class = shift;
243: my $self = {};
244: bless $self, $class;
245: $content =~ s/^.*content:.*?\"//i;
246: }
247: 
248: 
249: $theline =~ s/(<=|=>|=|\-|\+|\*|\/|\*\*|;|:|\\|\'|\"|,|\.|\(|\)|\[|\]|\{|\}|<|>)/\<span class\=\"op\"\>1ドル\<\/span>/g;
250: 
251: $theline =~ s/(<=|=>|=|\-|\+|\*|\/|\*\*|;|:|\\|\'|\"|,|\.|\(|\)|\[|\]|\{|\}|<|>)/g;
252: 
253: if($#ARGV==2){}
254: 
255: $someString =~ m/anything/gix ;
256: $someString =~ /anything/ ;
257: if($someString =~ /anything/g ){}
258: if( /anything/ ){}
259: 
260: if($somestring =~ s/something/something else/gi ){}
261: $somestring =~ /something/something else/ ;
262: $somestring =~ qr/something/something else/ ;
263: