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
Related
i have two files . one is user's input file and another file is original config file. After comparing two files , do add/delete functions in my original config file.
user's input file: (showing line by line)
add:L28A:Z:W #add--> DID ID --> Bin ID
del:L28C:B:Q:X:
rpl:L38A:B:M:D:
original input file
L28A:B:Q:M:X:
L28C:B:Q:M:X:
L38A:B:Q:M:X:
based on user's input file , first is doing add function second is delete function and third is replace function.
so output for original input txt file should show:
L28A:B:Q:M:X:Z:W
L28C:M:
L38A:B:M:D:
but my code is showing :
L28A:B:Q:M:X:
L28C:B:Q:M:X:
L38A:B:Q:M:X:
L28A:B:Q:M:X:Z:W
L28C:M:
L38A:B:M:D:
how can i replace above three lines with new modify lines?
use strict;
use warnings;
use File::Copy;
use vars qw($requestfile $requestcnt $configfile $config2cnt $my3file $myfile3cnt $new_file $new_filecnt #output);
my $requestfile = "DID1.txt"; #user's input file
my $configfile = "DID.txt"; #original config file
my $new_file = "newDID.txt";
readFileinString($requestfile, \$requestcnt);
readFileinString($configfile, \$config2cnt);
copy($configfile, $new_file) or die "The copy operation failed: $!";
while ($requestcnt =~ m/^((\w){3})\:([^\n]+)$/mig) #Each line from user request
{
my $action = $1;
my $requestFullLine = $3;
while ($requestFullLine =~ m/^((\w){4})\:([^\n]+)$/mig) #Each line from user request
{
my $DID = $1; #DID
my $requestBinList = $3; #Bin List in user request
#my #First_values = split /\:/, $requestBinList;
if ($config2cnt =~ m/^$DID\:([^\n]+)$/m) #configfile
{
my $ConfigFullLine = $1; #Bin list in config
my $testfile = $1;
my #First_values = split /\:/, $ConfigFullLine;
my #second_values = split /\:/, $requestBinList;
foreach my $sngletter(#second_values) # Each line from user request
{
if( grep {$_ eq "$sngletter"} #First_values)
{
print " $DID - $sngletter - Existing bin..\n\n";
}
else
{
print "$DID - $sngletter - Not existing bin..\n\n";
}
}
print "Choose option 1.Yes 2.No\n";
my $option = <STDIN>;
if ($option == 1) {
open(DES,'>>',$configfile) or die $!;
if($action eq 'add')
{
$ConfigFullLine =~ s/$/$requestBinList/g;
my $add = "$DID:$ConfigFullLine";
print DES "$add\n" ;
print"New Added Bin Valu $add\n\n";
}
if ( $action eq 'del')
{
foreach my $sngletter(#second_values){
$ConfigFullLine =~ s/$sngletter://g;
}
print DES "$DID:$ConfigFullLine\n";
print "New Deleted Bin Value $DID:$ConfigFullLine\n\n";
}
if ( $action eq 'rpl')
{
my $ConfigFullLine = $requestBinList;
my $replace = "$DID:$ConfigFullLine";
print DES "$replace\n";
print"Replace Bin Value $replace\n\n";
}
}
elsif ($option == 2)
{
print"Start from begining\n";
}
else
{
print "user chose invalid process or input is wrong\n";
}
}
else
{
print "New DID $DID detected\n";}
}
}
sub readFileinString
{
my $File = shift;
my $string = shift;
use File::Basename;
my $filenames = basename($File);
open(FILE1, "<$File") or die "\nFailed Reading File: [$File]\n\tReason: $!";
read(FILE1, $$string, -s $File, 0);
close(FILE1);
}
The problem is here:
open(DES,'>>',$configfile) or die $!;
You open your file for appending. So you get the original data, followed by your edited data.
Update: It appears that you have a working solution now, but I thought it might be interesting to show you how I would write this.
This program is a Unix filter. That is, it reads from STDIN and writes to STDOUT. I find that far more flexible than hard-coded filenames. You also don't have to explicitly open files - which saves time :-)
It also takes a command-line option, -c, telling it which file contains the edit definitions. So it is called like this (assuming we've called the program edit_files:
$ edit_files -c edit_definitions.txt < your_input_file > your_output_file
And here's the code.
#!/usr/bin/perl
use strict;
use warnings;
use Getopt::Std;
my %opts;
getopts('e:', \%opts);
my %edits = read_edits($opts{e});
while (<>) {
chomp;
my ($key, $val) = split /:/, $_, 2; #/ stop faulty syntax highlight
if (!exists $edits{$key}) {
print "$_\n";
next;
}
my $edit = $edits{$key};
if ($edit->[0] eq 'add') {
print "$_$edit->[1]\n";
} elsif ($edit->[0] eq 'del') {
$val =~ s/$_:// for split /:/, $edit->[1]; #/
print "$key:$val\n";
} elsif ($edit->[0] eq 'rpl') {
print "$key:$edit->[1]\n";
} else {
warn "$edit->[0] is an invalid edit type\n";
next;
}
}
sub read_edits {
my $file = shift;
open my $edit_fh, '<', $file or die $!;
my %edits;
while (<$edit_fh>) {
chomp;
# Remove comments
s/\s*#.*//; #/
my ($type, $key, $val) = split /:/, $_, 3; #/
$edits{$key} = [ $type, $val ];
}
}
Can somebody tell me how can we convert the rtf file into text with all the tags, tables and formatted data using perl programming language ?
#Ahmad Bilal , #petersergeant : I have been using the below code for RTF to TXT conversion and i am able to convert into text. But the problem is i am unable to capture table or image formats and even all the entities in the inputfile are not captured using the program.
use 5.8.0;
use strict;
use warnings;
use Getopt::Long;
use Pod::Usage;
use RTF::HTMLConverter;
#-------------------------------------------------------------------
#Variable Declarions
#-------------------------------------------------------------------
my $tempfile = "";
my $Outfile = "";
my $txtfile = "";
my $URL = "";
my $Format = "";
my $TreeBuilder = "";
my $Parsed = "";
my $line = "";
my %opts;
GetOptions(
"help|h|?" => \$opts{help},
"man|m" => \$opts{man},
"dom=s" => \$opts{dom},
"noimages|n" => \$opts{noimages},
"imagedir|d=s" => \$opts{imagedir},
"imageuri|u=s" => \$opts{imageuri},
"encoding|e=s" => \$opts{encoding},
"indented|i=i" => \$opts{indented},
);
pod2usage(-verbose => 1, -exitval => 0) if $opts{help};
pod2usage(-verbose => 2, -exitval => 0) if $opts{man};
my %params;
if($opts{dom}){
eval "require $opts{dom}";
die $# if $#;
$params{DOMImplementation} = $opts{dom};
}else{
eval { require XML::GDOME };
if($#){
eval { require XML::DOM };
die "Can't load either XML::GDOME or XML::DOM\n" if $#;
$params{DOMImplementation} = 'XML::DOM';
}
}
if($opts{noimages}){
$params{discard_images} = 1;
}else{
$params{image_dir} = $opts{imagedir} if defined $opts{imagedir};
$params{image_uri} = $opts{imageuri} if defined $opts{imageuri};
}
$params{codepage} = $opts{encoding} if $opts{encoding};
$params{formatting} = $opts{indented} if defined $opts{indented};
#-----------------------------------------------
# Converting RTF to HTML
#-----------------------------------------------
if(defined $ARGV[0]){
open(FR, "< $ARGV[0]") or die "Can't open '$ARGV[0]': $!!\n";
$params{in} = \*FR;
$tempfile = $ARGV[0];
$tempfile =~ /^(.*?)rtf/;
$Outfile = $1."html";
$txtfile = $1."txt";
open(FW, "> $Outfile") or die "Can't open '$Outfile': $!!\n";
$params{out} = \*FW;
print "\n$Outfile - HTML Created\n"
}
my $parser = RTF::HTMLConverter->new(%params);
$parser->parse();
close FW;
#-----------------------------------------------
# Opening HTML and TXT files
#-----------------------------------------------
open (FILE1, ">$txtfile") or die "Can't open '$txtfile': $!!\n";
open (FILE2, "$Outfile") or die "Can't open '$Outfile': $!!\n";
#-----------------------------------------------
# Converting HTML to TXT file
#-----------------------------------------------
local $/ = undef;
while ($line = <FILE2>) {
$line =~ s/\n//g;
$line =~ s/(<!DOCTYPE HTML.*><html><head>.*<\/style>)/<sectd>/;
$line =~ s/<font.*?>//g;
$line =~ s/<\/font>//g;
$line =~ s/<table .*?>/\n<table>\n/g;
$line =~ s/<\/table>/\n<\/table>/g;
$line =~ s/<td .*?>/\n<td>/g;
$line =~ s/<tr>/\n<tr>/g;
$line =~ s/<\/tr>/\n<\/tr>/g;
$line =~ s/<ul.*?>/\n<ul>/g;
$line =~ s/<li.*?>/\n<li>/g;
$line =~ s/<\/ul>/\n<\/ul>/g;
$line =~ s/<\/body><\/html>//g;
$line =~ s/<p.*?>/\n<p>/g;
$line =~ s/<p>( |\*|\s)+<\/p>//g;
$line =~ s/ //g;
$line =~ s/(<sectd>\n?.*?)<\/head><body>/$1/g;
#-------------------
# Entity Conversion
#-------------------
$line =~ s/’/‘/g;
$line =~ s/“/“/g;
$line =~ s/”/”/g;
$line =~ s/¶/¶/g;
print FILE1 $line;
}
print "$txtfile - TXT file Created \n";
close FILE1;
close FILE2;
unlink ("$Outfile");
I am the author of the linked module. Don't use it. If at all possible, shell out to a real RTF to text convertor like Pandoc.
you need to use a module like this:
http://search.cpan.org/~sargie/RTF-Parser-1.12/lib/RTF/TEXT/Converter.pm
I have a growing number of files to process using a simple Perl script I wrote. The script takes two files as input and prints an output. I want to use a bash script (or anything really) to automate the following usage:
perl Program.pl GeneLevels_A GeneLevels_B > GeneLevels_A_B
with every paired, non-directional combination of files in a particular directory.
Here is the Perl script:
#!/usr/bin/perl
use strict;
use warnings;
die "Usage: $0 <File_1> <File_2>\n" unless #ARGV == 2;
my $file1 = shift #ARGV;
my $file2 = shift #ARGV;
my %hash1;
my %hash2;
my $counter = 0;
my $amt = 25;
my $start = 244 - $amt;
open (REF, $file1);
while (<REF>) {
my $line = $_;
chomp $line;
if ($counter < $start) {
$counter++;
next;
}
my #cells = split('\t', $line);
my $ID = $cells[2];
my $row = $cells[0];
$hash1{$ID} = $row;
$counter++;
}
close REF;
$counter = 0;
open (FILE, $file2);
while (<FILE>) {
my $line = $_;
chomp $line;
if ($counter < $start) {
$counter++;
next;
}
my #cells = split('\t', $line);
my $ID = $cells[2];
my $row = $cells[0];
$hash2{$ID} = $row;
$counter++;
}
close FILE;
while ( my ($key, $value) = each(%hash1) ) {
if ( exists $hash2{$key} ) {
print "$key\t$value\t$hash2{$key}\n";
}
}
A good solution would allow me to run the Perl script on every file with an appropriate suffix.
An even better solution would assess the suffixes of existing files to determine which pairs of files have already been processed this way and omit those. For example if File_A, File_B, File_C, and File_B_C exist then only File_A_B and File_A_C would be produced. Note that File_A_B and File_B_A are equivalent.
This should work. Better checks for bad arguments would be a good thing to add:
#!/bin/bash
if [ $# != 2 ]; then
echo "usage: pair <suffix1> <suffix2>"
exit
fi
suffix1=$1
suffix2=$2
for file1 in *_${suffix1}; do
fileCheck=$(echo $file1 | sed -e "s#_$suffix2##")
if [ "$fileCheck" = "$file1" ]; then
file2=${file1/_$suffix1/_$suffix2}
if [[ ( ! -f ${file1}_${suffix2} ) && ( ! -f ${file2}_${suffix1} ) ]]; then
echo processing ${file1}_${suffix2}
perl Program.pl $file1 $file2 > ${file1}_${suffix2}
fi
fi
done
I've noticed that when you drag & drop a file into OS X Terminal and any part of the pathway contains a space (for example in a folder name) it substitutes this for a \
This then leads to an error in opening files in my script:
use strict;
use warnings;
use File::Basename;
my $in;
my $filename = $ARGV[0];
unless ($filename){
print "\n\nPlease drag and drop a FASTA/FA or plain-text file containing your sequence into the prompt window and hit ENTER. Alternatively, manually specify the file-pathway:\n";
$filename = <STDIN>;
chomp $filename;
}
open($in, $filename) or die "Failed to open $in: $!";
my $DNA = read_fasta($in);
my $len = length($DNA);
print "\nFASTA/Sequence Length is: $len bp \n";
print "\nPlease enter restriction sites (degeneracy characters permitted) seperated by a single space: ";
my $sites=<STDIN>;
chomp $sites;
my #pats = split ' ', $sites;
for (#pats) {
s/K/[GT]/g;
s/M/[AC]/g;
s/Y/[CT]/g;
s/S/[CG]/g;
s/W/[AT]/g;
s/B/[CGT]/g;
s/V/[ACG]/g;
s/H/[ACT]/g;
s/D/[AGT]/g;
s/X/[AGCT]/g;
s/R/[AG]/g;
s/N/[AGCT]/g;
}
for (#pats) {
my $m = () = $DNA =~ /$_/gi;
print "\nTotal DNA matches to $_ are: $m \n";
}
my $DIR = dirname($filename);
my $name = basename($filename);
(my $extrem = $name) =~ s/\.[^.]+$//;
open my $out, ">$DIR/$extrem $sites.txt";
my $pat=join("|",#pats);
my #cutarr = split(/$pat/, $DNA);
for (#cutarr) {
my $len = length($_);
print $out "$len \n";
}
print "\nYour results are located at: $DIR/$extrem $sites.txt\n\n";
close($out);
close($in);
#Subfunction - Reading formatted FASTA/FA files
sub read_fasta {
my ($fh) = #_;
my $sequence;
while (<$fh>) {
unless (/^>/) {
chomp;
$sequence .= $_;
}
}
return $sequence;
}
It will open files if the pathway contains no spaces. Is there a better way I can go about opening the file to avoid this occurring?
Try to remove backslashes from your file name,
$filename =~ tr|\\||d;
open(my $in, $filename) or die $!;
I am trying to do string manipulation in perl like so.
/q1.pl asad566sads asad575sads
then this prints
asad566sads
asad567sads
asad568sads
...
...
asad575sads
I am thinking somehow separate the string, then join it back up again?
#!/usr/bin/perl -w
if (#ARGV != 2){
print "error\n";
}else{
my $numb1 = $ARGV[0];
my $numb2 = $ARGV[1];
$numb1 =~ s/(\d*)\D/$1/g;
$numb2 =~ s/(\d*)\D/$1/g;
print "$numb1 \n";
print "$numb2 \n";
for ($i=$numb1; $i<$numb2; $i++){
#my $numb_2_print;
my $string_to_print = $ARGV[0];
$string_to_print =~ s/(\D*)\d(\D*)/$1$i$2/g;
print "$string_to_print\n";
}
}
EDIT: assume numbers on appear once in string for this question. sorry about that
#!/usr/bin/perl -w
use strict;
use warnings;
die "Invalid number of parameters" if #ARGV != 2;
my ($pref1, $num1, $suf1) = $ARGV[0] =~ /^(\D*)(\d+)(\D*)$/ or die "Invalid Parameter";
my ($pref2, $num2, $suf2) = $ARGV[1] =~ /^(\D*)(\d+)(\D*)$/ or die "Invalid Parameter";
die "Prefixes don't match" if ($pref1 ne $pref2);
die "Suffixes don't match" if ($suf1 ne $suf2);
print "$pref1$_$suf1\n" for ($num1..$num2);
Addendum: If you care about the numbers being the same length, you can use this printf statement instead
printf "%s%0" . length($num2) . "d%s\n", $pref1, $_, $suf1 for ($num1..$num2);
use Algorithm::Loops qw( NestedLoops );
my $s = 'a1a1';
my $e = 'a2a2';
my #s_parts = $s =~ /(\d+|\D+)/g;
my #e_parts = $e =~ /(\d+|\D+)/g;
die if #s_parts != #e_parts;
my #loops;
for my $i (0..$#s_parts) {
if ($s_parts[$i] =~ /^\d/) {
die if $s_parts[$i] > $e_parts[$i];
push #loops, [ $s_parts[$i] .. $e_parts[$i] ];
} else {
die if $s_parts[$i] ne $e_parts[$i];
push #loops, [ $s_parts[$i] ];
}
}
NestedLoops(\#loops, sub {
print(#_, "\n");
});
a1a1
a1a2
a2a1
a2a2
The range operator is your friend (http://perldoc.perl.org/perlop.html#Range-Operators):
#!/usr/bin/perl
use strict;
use warnings;
my ($start, $end) = #ARGV;
$start =~ s/([a-zA-Z]+)$//;
$end =~ s/([a-zA-Z]+)$//;
my $trailing = $1;
foreach ( $start..$end ) {
print "$_$trailing\n";
}
__END__
asad566sads
asad567sads
asad568sads
asad569sads
asad570sads
asad571sads
asad572sads
asad573sads
asad574sads
asad575sads