1#!/usr/bin/perl
2#
3# UUE library for HPT perl (c) Stas Mishchenkov 2:460/58
4#
5# This program is free software; you can redistribute it and/or modify
6# it under the terms of the GNU General Public License as published by
7# the Free Software Foundation; either version 2 of the License, or
8# (at your option) any later version.
9#
10# This program is distributed in the hope that it will be useful,
11# but WITHOUT ANY WARRANTY; without even the implied warranty of
12# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13# GNU General Public License for more details.
14#
15# Usage:
16# Put uue.pm somewere in @INC path. It's strongly recomended
17# for Windows users to put it in the same directory with filter.pl.
18#
19# Insert into config:
20# hptperlfile /home/fido/lib/filter.pl
21# and place to filter.pl some like this:
22#
23# use uue;
24#
25# sub put_msg {
26#     return uu_decode( $area, $text );
27# }
28# if uue is detected and decoded, the message will not be placed in the area.
29#
30# or
31# sub put_msg()
32# {
33#     if ( uu_decode( $area, $text ) == 0 ) {
34#         $text =~ s/\rbegin 644[ ]+([^ \r]+)\r[^ ]*\rend\r/\rbegin 644 $1\r\[ uue skipped \]\rend\r/g;
35#         $change=1;
36#     }
37#     return 1;
38# }
39# if uue is detected and decoded, uue code will be deleted from the message and
40# the message will be placed in the area.
41#
42# or
43# sub filter()
44# {
45#     uu_decode( $area, $text,undef,1 ) if defined( $area );
46# }
47# uue will be decoded from all echo areas. Decoded files will overwrite
48# existing files and will be placed in UUE subdirectory of ProtInbound from HPT
49# config file.
50#
51# or
52# sub filter()
53# {
54#     uu_decode( 'NetMail', $text, '/home/fido/files' ) if !defined( $area );
55# }
56# uue will be decoded from netmail area. Decoded files will overwrite
57# existing files and will be placed in '/home/fido/files/NETMAIL' directory.
58#
59# uu_decode( $area, $text, $decodedir, $overwrite );
60#            $area - Areatag. MUST be the echo area tag or 'NetMail'
61#            $text - MUST be message text
62#            $decodedir - Should be the full path to the directory, where you
63#                         wish to decode files. If not present, the default
64#                         name is UUE in ProtInbound from HPT config file.
65#            $overwrite - Should be 1, if you wish to overwrite existing files
66#                         by decoded files, 0 or undefined, if not.
67#                         Default is to not overwrite existing files by
68#                         renaming decoded files.
69# returns 0 if uue detected and 1 otherwise.
70#
71# uu_encode($filename, $mode);
72#           $filename - Fully qualified filename (with path) of file you wish
73#                       to uu encode.
74#           $mode     - May be omitted. Default is 0644.
75#
76#
77# Also it can be used in any perl script without HPT like this:
78#---- decode.pl ----
79# !/usr/bin/perl
80# use uue;
81#
82# my ($uuefile, $text, $size);
83#
84# if ( defined( @ARGV[0] ) ) {
85#     $uuefile = @ARGV[0];
86# } else { die "Usage: dec.pl path/filename.ext\n\n"; }
87#
88# my $size = -s $uuefile;
89# print "Decoding $uuefile, $size bytes\n";
90#
91# if ( open(F, "<$uuefile") ) {
92#    binmode(F);
93#    read(F, $text, $size);
94#    close(F);
95#    uu_decode("decoded", $text, '/home/fido/files', 1);
96# }
97#---- decode.pl ----
98#
99# or like this:
100#---- encode.pl ----
101# !/usr/bin/perl
102# use uue;
103#
104# my ($binfile, $uuefile);
105#
106# if ( defined( @ARGV[0] ) ) {
107#    $binfile = @ARGV[0];
108#    $uuefile = @ARGV[0] .".uue";
109# } else { die "Usage: dec.pl path/filename.ext\n\n"; }
110#
111# if ( open(F, ">$uuefile") ) {
112#    binmode(F);
113#    print( F uu_encode( $binfile ) );
114#    close(F);
115# }
116#---- encode.pl ----
117#
118
119
120sub uu_decode($$;$$)
121{
122	local ($marea, $mtext, $uuedir, $overwrite) = @_;
123	local ($slash, $uudecoded_data, @uuelines, $decdir, $ofile);
124
125	if ( $config{protInbound} =~ /([\\\/])/ ){
126		$slash = $1;
127	} else {
128		$ENV{TMP} =~ /([\\\/])/;
129		$slash = $1;
130	}
131	if ( !defined($uuedir) ){
132		$uuedir = $config{protInbound}."uue";
133	} else {
134		if ($uuedir =~ /(.*)[\\\/]$/){
135			$uuedir = $1;
136		}
137	}
138	local ($i, $d) = (0, $uuedir);
139	while ( -e $uuedir && !-d $uuedir) {
140		$uuedir = sprintf( "$d\.%04x", $i);
141		$i++;
142		if ($i >= 65535) { # maximum files for FA32 file system.
143			w_log("So may files \"$uuedir\".") if defined($config{protInbound});
144			print STDERR "So may files \"$uuedir\".\n";
145			return 1;
146		}
147	}
148	mkdir $uuedir if !-e $uuedir;
149	$i = 1;
150	while ( $mtext =~ /\r\n?begin 644[ ]+([^ \r\n?]+)\r\n?([^ ]*?\r\n?)end\r\n?/i ){
151	    @uuelines = split(/\r\n?/,$2);
152	    $decdir = $uuedir . $slash . uc($marea);
153	    $ofile = $decdir . $slash . $1;
154	    $ofile = find_free_filename($ofile) if !$overwrite;
155	    mkdir $decdir if !-e $decdir;
156	    if (open(F, ">$ofile")){
157		binmode(F);
158		foreach my $val ( @uuelines ){
159		    $uudecoded_data = unpack("u", $val);
160		    print(F $uudecoded_data);
161		}
162		close(F);
163		undef @uuelines;
164		$i = 0;
165	    } else {
166		w_log("Can't open \"$ofile\"\: $!\.") if defined($config{protInbound});
167		print STDERR "Can't open \"$ofile\"\: $!\.\n";
168	    }
169	$mtext =~ s/\r\n?begin 644[ ]+[^ \r\n?]+\r\n?[^ ]*?\r\n?end\r\n?/\r\n/i;
170	}
171return $i;
172}
173
174
175sub uu_encode($;$)
176{
177
178    local ($filename, $mode) = @_;
179    local ($uuestr, $bindata);
180
181    $mode ||= "644";
182    if ( $filename =~ /([^\\\/]+)$/ ) {
183       $uuestr = "\rbegin $mode $1\r";
184    } else {
185        w_log("Full path MUST be specified. $filename has no path.") if defined($config{protInbound});
186	print STDERR "Full path MUST be specified. $filename has no path.\n";
187        return '';
188    }
189    if ( open( FUU, $filename ) ) {
190	binmode( FUU, ':raw' );
191        while ( read( FUU, $bindata, 45 ) ) {
192            $uuestr .= pack("u", $bindata);
193        }
194        close(FUU);
195        $uuestr .= "end\r\r";
196        return($uuestr);
197    }
198    else {
199        w_log("Can't open \"$filename\"\: $!") if defined($config{protInbound});
200	print STDERR "Can't open \"$filename\"\: $!\n";
201        return('');
202    }
203}
204
205sub find_free_filename($)
206{
207    local ($o_file) = @_;
208    local ($o_fname, $o_ext);
209    if ( $o_file =~ /^(.*)(\.[^\.\\\/]+)$/ ) {
210       ($o_fname, $o_ext) = ($1, $2);
211    } else {
212       ($o_fname, $o_ext) = ($o_file, '');
213    }
214    local $o_i = 0;
215    while (-e $o_file) {
216	$o_file = sprintf("$o_fname%04x$o_ext", $o_i);
217	$o_i++;
218	if ($o_i > 65535) {
219	    $o_file = $o_fname . $o_ext;
220	}
221    }
222return $o_file;
223}
224
2251;
226