1 rizwank 1.1 # Module of TWiki Collaboration Platform, http://TWiki.org/
  2             #
  3             # Copyright (C) 2001-2004 Peter Thoeny, peter@thoeny.com
  4             #
  5             # For licensing info read license.txt file in the TWiki root.
  6             # This program is free software; you can redistribute it and/or
  7             # modify it under the terms of the GNU General Public License
  8             # as published by the Free Software Foundation; either version 2
  9             # of the License, or (at your option) any later version.
 10             #
 11             # This program is distributed in the hope that it will be useful,
 12             # but WITHOUT ANY WARRANTY; without even the implied warranty of
 13             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 14             # GNU General Public License for more details, published at 
 15             # http://www.gnu.org/copyleft/gpl.html
 16             #
 17             # Notes:
 18             # - Latest version at http://twiki.org/
 19             # - Installation instructions in $dataDir/TWiki/TWikiDocumentation.txt
 20             # - Customize variables in TWiki.cfg when installing TWiki.
 21             #
 22 rizwank 1.1 #  14-02-2001 - Nicholas Lee
 23             
 24             =begin twiki
 25             
 26             ---+ TWiki::Net Module
 27             
 28             This module handles network related functions like http access and
 29             send mail.
 30             
 31             =cut
 32             
 33             package TWiki::Net;
 34             
 35             use strict;
 36             
 37             use vars qw(
 38                     $useNetSmtp
 39                     $mailInitialized $mailHost $helloHost
 40                 );
 41             
 42             BEGIN {
 43 rizwank 1.1     $useNetSmtp = 0;
 44                 $mailInitialized = 0;
 45             }
 46             
 47             # =========================
 48             =pod
 49             
 50             ---++ sub getUrl (  $theHost, $thePort, $theUrl, $theUser, $thePass, $theHeader  )
 51             
 52             Not yet documented.
 53             
 54             =cut
 55             
 56             sub getUrl
 57             {
 58                 my ( $theHost, $thePort, $theUrl, $theUser, $thePass, $theHeader ) = @_;
 59             
 60                 # Run-time use of Socket module when needed
 61                 require Socket;
 62                 import Socket qw(:all);
 63             
 64 rizwank 1.1     if( $thePort < 1 ) {
 65                     $thePort = 80;
 66                 }
 67                 my $base64;
 68                 my $result = '';
 69                 $theUrl = "/" unless( $theUrl );
 70                 my $req = "GET $theUrl HTTP/1.0\r\n";
 71             
 72                 # RNF 22 Jan 2002 Support for vhosts and user authentication.
 73                 $req .= "Host: $theHost\r\n";
 74                 if( $theUser && $thePass ) {
 75             	# Use MIME::Base64 at run-time if using outbound proxy with 
 76             	# authentication
 77             	require MIME::Base64;
 78             	import MIME::Base64 ();
 79                     $base64 = encode_base64( "$theUser:$thePass", "\r\n" );
 80                     $req .= "Authorization: Basic $base64";
 81                 }
 82             
 83                 # RNF 19 Apr 2002 Support for outbound proxies.
 84                 my $proxyHost = &TWiki::Prefs::getPreferencesValue("PROXYHOST");
 85 rizwank 1.1     my $proxyPort = &TWiki::Prefs::getPreferencesValue("PROXYPORT");
 86                 if($proxyHost && $proxyPort) {
 87                     $req = "GET http://$theHost$theUrl HTTP/1.0\r\n";
 88                     $theHost = $proxyHost;
 89                     $thePort = $proxyPort;
 90                 }
 91             
 92                 $req .= $theHeader if( $theHeader );
 93                 $req .= "\r\n\r\n";
 94             
 95                 my ( $iaddr, $paddr, $proto );
 96                 $iaddr   = inet_aton( $theHost );
 97                 $paddr   = sockaddr_in( $thePort, $iaddr );
 98                 $proto   = getprotobyname( 'tcp' );
 99                 unless( socket( *SOCK, &PF_INET, &SOCK_STREAM, $proto ) ) {
100                     &TWiki::writeWarning( "TWiki::Net::getUrl socket: $!" );
101                     return "content-type: text/plain\n\nERROR: TWiki::Net::getUrl socket: $!.";
102                 }
103                 unless( connect( *SOCK, $paddr ) ) {
104                     &TWiki::writeWarning( "TWiki::Net::getUrl connect: $!" );
105                     return "content-type: text/plain\n\nERROR: TWiki::Net::getUrl connect: $!. \n$req";
106 rizwank 1.1     }
107                 select SOCK; $| = 1;
108                 print SOCK $req;
109                 while( <SOCK> ) { $result .= $_; }
110                 unless( close( SOCK ) ) {
111                     &TWiki::writeWarning( "TWiki::Net::getUrl close: $!" );
112                 }
113                 select STDOUT;
114                 return $result;
115             }
116             
117             # =========================
118             =pod
119             
120             ---++ sub sendEmail (  $theText  )
121             
122             Not yet documented.
123             
124             =cut
125             
126             sub sendEmail
127 rizwank 1.1 {
128                 # $theText Format: "Date: ...\nFrom: ...\nTo: ...\nCC: ...\nSubject: ...\n\nMailBody..."
129             
130                 my( $theText ) = @_;
131             
132                 # Put in a Date header, mainly for Qmail
133                 my $dateStr = &TWiki::formatTime(time, 'email');
134                 $theText = "Date: " . $dateStr . "\n" . $theText;
135             
136                 # Check if Net::SMTP is available
137                 if( ! $mailInitialized ) {
138                     $mailInitialized = 1;
139                     $mailHost  = &TWiki::Prefs::getPreferencesValue( "SMTPMAILHOST" );
140                     $helloHost = &TWiki::Prefs::getPreferencesValue( "SMTPSENDERHOST" );
141                     if( $mailHost ) {
142             	   eval {	# May fail if Net::SMTP not installed
143             	       $useNetSmtp = require Net::SMTP;
144             	   }
145                     }
146                 }
147             
148 rizwank 1.1     my $error = "";
149                 # Send the email.  Use Net::SMTP if it's installed, otherwise use a
150                 # sendmail type program.
151                 if( $useNetSmtp ) {
152                     my ( $header, $body ) = split( "\n\n", $theText, 2 );
153                     my @headerlines = split( /\n/, $header );
154                     $header =~ s/\nBCC\:[^\n]*//os;  #remove BCC line from header
155                     $header =~ s/([\n\r])(From|To|CC|BCC)(\:\s*)([^\n\r]*)/$1 . $2 . $3 . _fixLineLength( $4 )/geois;
156                     $theText = "$header\n\n$body";   # rebuild message
157             
158                     # extract 'From:'
159                     my $from = "";
160                     my @arr = grep( /^From: /i, @headerlines );
161                     if( scalar( @arr ) ) {
162                         $from = $arr[0];
163                         $from =~ s/^From:\s*//io;
164                         $from =~ s/.*<(.*?)>.*/$1/o; # extract "user@host" out of "Name <user@host>"
165                     }
166                     if( ! ( $from ) ) {
167                         return "ERROR: Can't send mail, missing 'From:'";
168                     }
169 rizwank 1.1 
170                     # extract @to from 'To:', 'CC:', 'BCC:'
171                     my @to = ();
172                     @arr = grep( /^To: /i, @headerlines );
173                     my $tmp = "";
174                     if( scalar( @arr ) ) {
175                         $tmp = $arr[0];
176                         $tmp =~ s/^To:\s*//io;
177                         @arr = split( /[,\s]+/, $tmp );
178                         push( @to, @arr );
179                     }
180                     @arr = grep( /^CC: /i, @headerlines );
181                     if( scalar( @arr ) ) {
182                         $tmp = $arr[0];
183                         $tmp =~ s/^CC:\s*//io;
184                         @arr = split( /[,\s]+/, $tmp );
185                         push( @to, @arr );
186                     }
187                     @arr = grep( /^BCC: /i, @headerlines );
188                     if( scalar( @arr ) ) {
189                         $tmp = $arr[0];
190 rizwank 1.1             $tmp =~ s/^BCC:\s*//io;
191                         @arr = split( /[,\s]+/, $tmp );
192                         push( @to, @arr );
193                     }
194             
195                     if( ! ( scalar( @to ) ) ) {
196                         return "ERROR: Can't send mail, missing receipient";
197                     }
198             
199                     $error = _sendEmailByNetSMTP( $from, \@to, $theText );
200             
201                 } else {
202                     # send with sendmail
203                     my ( $header, $body ) = split( "\n\n", $theText, 2 );
204                     $header =~ s/([\n\r])(From|To|CC|BCC)(\:\s*)([^\n\r]*)/$1 . $2 . $3 . _fixLineLength( $4 )/geois;
205                     $theText = "$header\n\n$body";   # rebuild message
206                     $error = _sendEmailBySendmail( $theText );
207                 }
208                 return $error;
209             }
210             
211 rizwank 1.1 # =========================
212             =pod
213             
214             ---++ sub _fixLineLength (  $theAddrs  )
215             
216             Not yet documented.
217             
218             =cut
219             
220             sub _fixLineLength
221             {
222                 my( $theAddrs ) = @_;
223                 # split up header lines that are too long
224                 $theAddrs =~ s/(.{60}[^,]*,\s*)/$1\n        /go;
225                 $theAddrs =~ s/\n\s*$//gos;
226                 return $theAddrs;
227             }
228             
229             # =========================
230             =pod
231             
232 rizwank 1.1 ---++ sub _sendEmailBySendmail (  $theText  )
233             
234             Not yet documented.
235             
236             =cut
237             
238             sub _sendEmailBySendmail
239             {
240                 my( $theText ) = @_;
241             
242                 if( open( MAIL, "|-" ) || exec "$TWiki::mailProgram" ) {
243                     print MAIL $theText;
244                     close( MAIL );
245                     return "";
246                 }
247                 return "ERROR: Can't send mail using TWiki::mailProgram";
248             }
249             
250             # =========================
251             =pod
252             
253 rizwank 1.1 ---++ sub _sendEmailByNetSMTP (  $from, $toref, $data  )
254             
255             Not yet documented.
256             
257             =cut
258             
259             sub _sendEmailByNetSMTP
260             {
261                 my( $from, $toref, $data ) = @_;
262             
263                 my @to;
264                 # $to is not a reference then it must be a single email address
265                 @to = ($toref) unless ref( $toref ); 
266                 if ( ref( $toref ) =~ /ARRAY/ ) {
267             	@to = @{$toref};
268                 }
269                 return undef unless( scalar @to );
270                 
271                 my $smtp = 0;
272                 if( $helloHost ) {
273                     $smtp = Net::SMTP->new( $mailHost, Hello => $helloHost );
274 rizwank 1.1     } else {
275                     $smtp = Net::SMTP->new( $mailHost );
276                 }
277                 my $status = "";
278                 if ($smtp) {
279                     {
280                         $smtp->mail( $from ) or last;
281                         $smtp->to( @to, { SkipBad => 1 } ) or last;
282                         $smtp->data( $data ) or last;
283                         $smtp->dataend() or last;
284             	}
285             	$status = ($smtp->ok() ? "" : "ERROR: Can't send mail using Net::SMTP. " . $smtp->message );
286             	$smtp->quit();
287             
288                 } else {
289             	$status = "ERROR: Can't send mail using Net::SMTP (can't connect to '$mailHost')";
290                 }
291                 return $status;    
292             }
293             
294             # =========================
295 rizwank 1.1 
296             1;
297             
298             # EOF