Upload file using Perl CGI - html

I am able to create my directory but I cannot seem to place the file in the directory.
#!/usr/bin/perl
use Cwd;
use CGI;
my $dir = getcwd();
print "Current Working Directory: $ dir\n";
my $photoDir = "$dir/MyPhotos";
mkdir $photoDir
or die "Cannot mkdir $photoDir: $!"
unless -d $photoDir;
my $query = new CGI;
my $filename = $query->param("Photo");
my $description = $query->param("description");
print "Current filename: $filename\n";
my ( $name, $path, $extension ) = fileparse ( $filename, '\..*' ); $filename = $name . $extension;
print $filename;
my $upload_filehandle = $query->upload("Photo");
open ( UPLOADFILE, ">$photoDir/$filename" )
or die "$!";
binmode UPLOADFILE;
while ( <$upload_filehandle> )
{ print UPLOADFILE; }
close UPLOADFILE;
The CGI stack trace shows no errors but the log shows there is no output
LOG: 5 5020-0:0:0:0:0:0:0:1%0-9: CGI output 0 bytes.

CGI.pm manual suggests this path to saving uploaded files. Try this additional check and write method and see if it helps.
$lightweight_fh = $q->upload('field_name');
# undef may be returned if it's not a valid file handle
if (defined $lightweight_fh) {
# Upgrade the handle to one compatible with IO::Handle:
my $io_handle = $lightweight_fh->handle;
open (OUTFILE,'>>','/usr/local/web/users/feedback');
while ($bytesread = $io_handle->read($buffer,1024)) {
print OUTFILE $buffer;
}
}
Also make sure you have your HTML form has required type like this: <form action=... method=post enctype="multipart/form-data">

Related

Compare 2 CSV Huge CSV Files and print the differences to another csv file using perl

I have 2 csv files of multiple fields(approx 30 fields), and huge size ( approx 4GB ).
File1:
EmployeeName,Age,Salary,Address
Vinoth,12,2548.245,"140,North Street,India"
Vivek,40,2548.245,"140,North Street,India"
Karthick,10,10.245,"140,North Street,India"
File2:
EmployeeName,Age,Salary,Address
Vinoth,12,2548.245,"140,North Street,USA"
Karthick,10,10.245,"140,North Street,India"
Vivek,40,2548.245,"140,North Street,India"
I want to compare these 2 files and report the differences into another csv file. In the above example, Employee Vivek and Karthick details are present in different row numbers but still the record data is same, so it should be considered as match. Employee Vinoth record should be considered as a mismatch since there is a mismatch in the address.
Output diff.csv file can contain the mismatched record from the File1 and File 2 as below.
Diff.csv
EmployeeName,Age,Salary,Address
F1, Vinoth,12,2548.245,"140,North Street,India"
F2, Vinoth,12,2548.245,"140,North Street,USA"
I've written the code so far as below. After this I'm confused which option to choose whether a Binary Search or any other efficient way to do this. Could you please help me?
My approach
1. Load the File2 in memory as hashes of hashes.
2.Read line by line from File1 and match it with the hash of hashes in memory.
use strict;
use warnings;
use Text::CSV_XS;
use Getopt::Long;
use Data::Dumper;
use Text::CSV::Hashify;
use List::BinarySearch qw( :all );
# Get Command Line Parameters
my %opts = ();
GetOptions( \%opts, "file1=s", "file2=s", )
or die("Error in command line arguments\n");
if ( !defined $opts{'file1'} ) {
die "CSV file --file1 not specified.\n";
}
if ( !defined $opts{'file2'} ) {
die "CSV file --file2 not specified.\n";
}
my $file1 = $opts{'file1'};
my $file2 = $opts{'file2'};
my $file3 = 'diff.csv';
print $file2 . "\n";
my $csv1 =
Text::CSV_XS->new(
{ binary => 1, auto_diag => 1, sep_char => ',', eol => $/ } );
my $csv2 =
Text::CSV_XS->new(
{ binary => 1, auto_diag => 1, sep_char => ',', eol => $/ } );
my $csvout =
Text::CSV_XS->new(
{ binary => 1, auto_diag => 1, sep_char => ',', eol => $/ } );
open( my $fh1, '<:encoding(utf8)', $file1 )
or die "Cannot not open '$file1' $!.\n";
open( my $fh2, '<:encoding(utf8)', $file2 )
or die "Cannot not open '$file2' $!.\n";
open( my $fh3, '>:encoding(utf8)', $file3 )
or die "Cannot not open '$file3' $!.\n";
binmode( STDOUT, ":utf8" );
my $f1line = undef;
my $f2line = undef;
my $header1 = undef;
my $f1empty = 'false';
my $f2empty = 'false';
my $reccount = 0;
my $hash_ref = hashify( "$file2", 'EmployeeName' );
if ( $f1empty eq 'false' ) {
$f1line = $csv1->getline($fh1);
}
while (1) {
if ( $f1empty eq 'false' ) {
$f1line = $csv1->getline($fh1);
}
if ( !defined $f1line ) {
$f1empty = 'true';
}
if ( $f1empty eq 'true' ) {
last;
}
else {
## Read each line from File1 and match it with the File 2 which is loaded as hashes of hashes in perl. Need help here.
}
}
print "End of Program" . "\n";
Storing data of such magnitude in database is most correct approach to tasks of this kind. At minimum SQLlite is recommended but other databases MariaDB, MySQL, PostgreSQL will work quite well.
Following code demonstrates how desired output can be achieved without special modules, but it does not take in account possibly messed up input data. This script will report data records as different even if difference can be just one extra space.
Default output is into console window unless you specify option output.
NOTE: Whole file #1 is read into memory, please be patient processing big files can take a while.
use strict;
use warnings;
use feature 'say';
use Getopt::Long qw(GetOptions);
use Pod::Usage;
my %opt;
my #args = (
'file1|f1=s',
'file2|f2=s',
'output|o=s',
'debug|d',
'help|?',
'man|m'
);
GetOptions( \%opt, #args ) or pod2usage(2);
print Dumper(\%opt) if $opt{debug};
pod2usage(1) if $opt{help};
pod2usage(-exitval => 0, -verbose => 2) if $opt{man};
pod2usage(1) unless $opt{file1};
pod2usage(1) unless $opt{file2};
unlink $opt{output} if defined $opt{output} and -f $opt{output};
compare($opt{file1},$opt{file2});
sub compare {
my $fname1 = shift;
my $fname2 = shift;
my $hfile1 = file2hash($fname1);
open my $fh, '<:encoding(utf8)', $fname2
or die "Couldn't open $fname2";
while(<$fh>) {
chomp;
next unless /^(.*?),(.*)$/;
my($key,$data) = ($1, $2);
if( !defined $hfile1->{$key} ) {
my $msg = "$fname1 $key is missing";
say_msg($msg);
} elsif( $data ne $hfile1->{$key} ) {
my $msg = "$fname1 $key,$hfile1->{$key}\n$fname2 $_";
say_msg($msg);
}
}
}
sub say_msg {
my $msg = shift;
if( $opt{output} ) {
open my $fh, '>>:encoding(utf8)', $opt{output}
or die "Couldn't to open $opt{output}";
say $fh $msg;
close $fh;
} else {
say $msg;
}
}
sub file2hash {
my $fname = shift;
my %hash;
open my $fh, '<:encoding(utf8)', $fname
or die "Couldn't open $fname";
while(<$fh>) {
chomp;
next unless /^(.*?),(.*)$/;
$hash{$1} = $2;
}
close $fh;
return \%hash;
}
__END__
=head1 NAME
comp_cvs - compares two CVS files and stores differense
=head1 SYNOPSIS
comp_cvs.pl -f1 file1.cvs -f2 file2.cvs -o diff.txt
Options:
-f1,--file1 input CVS filename #1
-f2,--file2 input CVS filename #2
-o,--output output filename
-d,--debug output debug information
-?,--help brief help message
-m,--man full documentation
=head1 OPTIONS
=over 4
=item B<-f1,--file1>
Input CVS filename #1
=item B<-f2,--file2>
Input CVS filename #2
=item B<-o,--output>
Output filename
=item B<-d,--debug>
Print debug information.
=item B<-?,--help>
Print a brief help message and exits.
=item B<--man>
Prints the manual page and exits.
=back
=head1 DESCRIPTION
B<This program> accepts B<input> and processes to B<output> with purpose of achiving some goal.
=head1 EXIT STATUS
The section describes B<EXIT STATUS> codes of the program
=head1 ENVIRONMENT
The section describes B<ENVIRONMENT VARIABLES> utilized in the program
=head1 FILES
The section describes B<FILES> which used for program's configuration
=head1 EXAMPLES
The section demonstrates some B<EXAMPLES> of the code
=head1 REPORTING BUGS
The section provides information how to report bugs
=head1 AUTHOR
The section describing author and his contanct information
=head1 ACKNOWLEDGMENT
The section to give credits people in some way related to the code
=head1 SEE ALSO
The section describing related information - reference to other programs, blogs, website, ...
=head1 HISTORY
The section gives historical information related to the code of the program
=head1 COPYRIGHT
Copyright information related to the code
=cut
Output for test files
file1.cvs Vinoth,12,2548.245,"140,North Street,India"
file2.cvs Vinoth,12,2548.245,"140,North Street,USA"
#!/usr/bin/env perl
use Data::Dumper;
use Digest::MD5;
use 5.01800;
use warnings;
my %POS;
my %chars;
open my $FILEA,'<',q{FileA.txt}
or die "Can't open 'FileA.txt' for reading! $!";
open my $FILEB,'<',q{FileB.txt}
or die "Can't open 'FileB.txt' for reading! $!";
open my $OnlyInA,'>',q{OnlyInA.txt}
or die "Can't open 'OnlyInA.txt' for writing! $!";
open my $InBoth,'>',q{InBoth.txt}
or die "Can't open 'InBoth.txt' for writing! $!";
open my $OnlyInB,'>',q{OnlyInB.txt}
or die "Can't open 'OnlyInB.txt' for writing! $!";
<$FILEA>,
$POS{FILEA}=tell $FILEA;
<$FILEB>,
$POS{FILEB}=tell $FILEB;
warn Data::Dumper->Dump([\%POS],[qw(*POS)]),' ';
{ # Scan for first character of the records involved
while (<$FILEA>) {
$chars{substr($_,0,1)}++;
};
while (<$FILEB>) {
$chars{substr($_,0,1)}--;
};
# So what characters do we need to deal with?
warn Data::Dumper->Dump([\%chars],[qw(*chars)]),' ';
};
my #chars=sort keys %chars;
{
my %_h;
# For each of the characters in our character set
for my $char (#chars) {
warn Data::Dumper->Dump([\$char],[qw(*char)]),' ';
# Beginning of data sections
seek $FILEA,$POS{FILEA},0;
seek $FILEB,$POS{FILEB},0;
%_h=();
my $pos=tell $FILEA;
while (<$FILEA>) {
next
unless (substr($_,0,1) eq $char);
# for each record save the lengthAndMD5 as the key and its start as the value
$_h{lengthAndMD5(\$_)}=$pos;
$pos=tell $FILEA;
};
my $_s;
while (<$FILEB>) {
next
unless (substr($_,0,1) eq $char);
if (exists $_h{$_s=lengthAndMD5(\$_)}) { # It's a duplicate
print {$InBoth} $_;
delete $_h{$_s};
}
else { # (Not in FILEA) It's only in FILEB
print {$OnlyInB} $_;
}
};
# only in FILEA
warn Data::Dumper->Dump([\%_h],[qw(*_h)]),' ';
for my $key (keys %_h) { # Only in FILEA
seek $FILEA,delete $_h{$key},0;
print {$OnlyInA} scalar <$FILEA>;
};
# Should be empty
warn Data::Dumper->Dump([\%_h],[qw(*_h)]),' ';
};
};
close $OnlyInB
or die "Could NOT close 'OnlyInB.txt' after writing! $!";
close $InBoth
or die "Could NOT close 'InBoth.txt' after writing! $!";
close $OnlyInA
or die "Could NOT close 'OnlyInA.txt' after writing! $!";
close $FILEB
or die "Could NOT close 'FileB.txt' after reading! $!";
close $FILEA
or die "Could NOT close 'FileA.txt' after reading! $!";
exit;
sub lengthAndMD5 {
return sprintf("%8.8lx-%32.32s",length(${$_[0]}),Digest::MD5::md5_hex(${$_[0]}));
};
__END__

Check for HTTP Code in fetch_json sub / save previous output for backup in Perl

so I have to update a perl script that goes through a json file, fetches keys called “items”, and transforms these items into perl output.
I’m a noob at Perl/coding in general, so plz bear with me🥺. The offset variable is set as each url is iterated through. A curl command is passed to the terminal, the file is put through a "#lines" array, and in the end, whatever json data is stored in $data gets decoded and transformed. and in the blocks below (where # populate %manager_to_directs, # populate %user_to_management_chain, and # populate %manager_to_followers are commented) is where fetch_json gets called and where the hash variables get the data from the decoded json. (***Please feel free to correct me if I interpreted this code incorrectly)
There’s been a problem where the $cmd doesn’t account for the HTTP Responses every time this program is executed. I only want the results to be processed if and only if the program gets http 200 (OK) or http 204 (NO_CONTENT) because the program will run and sometimes partially refresh our json endpoint (url in curl command output from terminal below), or sometimes doesn’t even refresh at all.
All I’m assuming is that I’d probably have to import the HTTP::Response pragma and somehow pull that out of the commands being run in fetch_json, but I have no other clue where to go from there.
Would I have to update the $cmd to pull the http code? And if so, how would I interpret that in the fetch_json sub to exit the process if anything other than 200 or 204 is received?
Oh and also, how would I save the previous output from the last execution in a backup file?
Any help I can get here would be highly appreciated!
See code below:
Pulling this from a test run:
curl -o filename -w "HTTP CODE: %{http_code}\n" --insecure --key <YOUR KEY> --cert <YOUR CERT> https://xxxxxxxxxx-xxxxxx-xxxx.xxx.xxxxxxxxxx.com:443/api/v1/reports/active/week > http.out
#!/usr/bin/env perl
use warnings;
use strict;
use JSON qw(decode_json);
use autodie qw(open close chmod unlink);
use File::Basename;
use File::Path qw(make_path rmtree);
use Cwd qw(abs_path);
use Data::Dumper;
use feature qw(state);
sub get_fetched_dir {
return "$ENV{HOME}/tmp/mule_user_fetched";
}
# fetch from mulesoft server and save local copy
sub fetch_json {
state $now = time();
my ($url) = #_;
my $dir = get_fetched_dir();
if (!-e $dir) {
make_path($dir);
chmod 0700, $dir;
}
my ($offset) = $url =~ m{offset=(\d+)};
if (!defined $offset) {
$offset = 0;
}
$offset = sprintf ("%03d", $offset);
my $filename = "$dir/offset${offset}.json";
print "$filename\n";
my #fields = stat $filename;
my $size = $fields[7];
my $mtime = $fields[9];
if (!$size || !$mtime || $now-$mtime > 24*60*60) {
my $cmd = qq(curl \\
--insecure \\
--silent \\
--key $ENV{KEY} \\
--cert $ENV{CERT} \\
$url > $filename
);
#print $cmd;
system($cmd);
chmod 0700, $filename;
}
open my $fh, "<", $filename;
my #lines = <$fh>;
close $fh;
return undef if !#lines;
my $data;
eval {
$data = decode_json (join('',#lines));
};
if ($#) {
unlink $filename;
print "Bad JSON detected in $filename.\n";
print "I have deleted $filename.\n";
print "Please re-run script.\n";
exit(1);
}
return $data;
}
die "Usage:\n KEY=key_file CERT=cert_file mule_to_jira.pl\n"
if !defined $ENV{KEY} || !defined $ENV{CERT};
print "fetching data from mulesoft\n";
# populate %manager_to_directs
my %manager_to_directs;
my %user_to_manager;
my #users;
my $url = "https://enterprise-worker-data.eip.vzbuilders.com/api/v1/reports/active/week";
while ($url && $url ne "Null") {
my $data = fetch_json($url);
last if !defined $data;
$url = $data->{next};
#print $url;
my $items = $data->{items};
foreach my $item (#$items) {
my $shortId = $item->{shortId};
my $manager = $item->{organization}{manager};
push #users, $shortId;
next if !$manager;
$user_to_manager{$shortId} = $manager;
push #{$manager_to_directs{$manager}}, $shortId;
}
}
# populate %user_to_management_chain
# populate %manager_to_followers
my %user_to_management_chain;
my %manager_to_followers;
foreach my $user (keys %user_to_manager) {
my $manager = $user_to_manager{$user};
my $prev = $user;
while ($manager && $prev ne $manager) {
push #{$manager_to_followers{$manager}}, $user;
push #{$user_to_management_chain{$user}}, $manager;
$prev = $manager;
$manager = $user_to_manager{$manager}; # manager's manager
}
}
# write backyard.txt
open my $backyard_fh, ">", "backyard.txt";
foreach my $user (sort keys %user_to_management_chain) {
my $chain = join ',', #{$user_to_management_chain{$user}};
print $backyard_fh "$user:$chain\n";
}
close $backyard_fh;
# write teams.txt
open my $team_fh, ">", "teams.txt";
foreach my $user (sort #users) {
my $followers = $manager_to_followers{$user};
my $followers_joined = $followers ? join (',', sort #$followers) : "";
print $team_fh "$user:$followers_joined\n";
}
close $team_fh;
my $dir = get_fetched_dir();
rmtree $dir, {safe => 1};
So, if you want to keep the web fetch and the Perl processing decoupled, you can modify the curl command so that it includes the response header in the output by adding the -i option. That means that the Perl will have to be modified to read and process the headers before getting to the body. A successful http.out will look something like this:
HTTP/1.1 200 OK
Server: somedomain.com
Date: <date retrieved>
Content-Type: application/json; charset=utf-8
Content-Length: <size of JSON>
Status: 200 OK
Maybe: More Headers
Blank: Line signals start of body
{
JSON object here
}
An unsuccessful curl will have something other than 200 OK on the first line next to the HTTP/1.1, so you can tell that something went wrong.
Alternatively, you can let the Perl do the actual HTTP fetch instead of relying on curl; you can use LWP::UserAgent or any of a number of other HTTP client libraries in Perl, which will give you the entire response, not just the body.

HTML tag parsing script

I've written an HTML tag parsing script that I think should work but I'm getting a file not found error. Maybe I'm having a senior moment but I'm stuck. I have all of the *.html files that I want to parse in a directory called Test and I am executing the perl script from a folder called temp that has the directory Test in it. The exact error is: Error opening Test/1.html: No such file or directory.
Here's the code:
#!/usr/bin/perl
use strict;
use warnings;
use File::Find;
use HTTP::Headers;
use HTML::HeadParser;
use Text::CSV;
my $csv1 = Text::CSV->new ( { binary => 1 } ) or die Text::CSV->error_diag();
$csv1->eol ("\n");
my $dfile = 'all_tags.csv';
open my $fh1, ">:encoding(utf8)", "$dfile" or die "Error opening $dfile: $!";
my $dir = 'Test';
find (\&HTML_Files, $dir);
print "directory is";
print $dir;
close $fh1 or die "Error closing $dfile: $!";
exit;
sub HTML_Files {
Parse_HTML_Header($File::Find::name) if /\.html?$/;
}
sub Parse_HTML_Header {
my $ifile = shift;
open(my $fh0, '<', $ifile) or die "Error opening $ifile: $!\n";
my $text = '';
{
$/ = undef;
$text = <$fh0>;
}
close $fh0;
my $h = HTTP::Headers->new;
my $p = HTML::HeadParser->new($h);
$p->parse($text);
for ($h->header_field_names) {
my #values = split ',', $h->header($_);
if (/keywords/i) {
$csv1->print ($fh1, \#values);
} elsif (/description/i) {
$csv1->print ($fh1, \#values);
} elsif (/title/i) {
$csv1->print ($fh1, \#values);
}
}
}
It's because File::Find is doing a chdir as it runs. You should pass $_ instead of $File::Find::name. Or set no_chdir:
no_chdir
Does not chdir() to each directory as it recurses. The wanted() function will need to be aware of this, of course. In this case, $_ will be the same as $File::Find::name .
Because you are specifying a relative path, $File::Find::name is also a relative path. You can avoid this by specifying a full path to find as well. (e.g. /full/path/to/dir)

Perl mechanize print HTML form names

I'm trying to automate hotmail login. How can I find what the appropriate fields are? When I print the forms I just get a bunch of hex information.
what's the correct method and how is it used?
use WWW::Mechanize;
use LWP::UserAgent;
my $mech = WWW::Mechanize->new();
my $url = "http://hotmail.com";
$mech->get($url);
print "Forms: $mech->forms";
if ($mech->success()){
print "Successful Connection\n";
} else {
print "Not a successful connection\n"; }
this may help you
use WWW::Mechanize;
use Data::Dumper;
my $mech = WWW::Mechanize->new();
my $url = "http://yoururl.com";
$mech->get($url);
my #forms = $mech->forms;
foreach my $form (#forms) {
my #inputfields = $form->param;
print Dumper \#inputfields;
}
Sometimes it is useful to look at what the web site is asking in advance of coding up a reader or interface to it.
I wrote this bookmarklet that you save in your browser bookmarks and when you click it while visiting any html web page will show in a pop-up all the forms actions and fields with values even hidden. Simply copy the text below and paste into a new bookmark location field, name it and save.
javascript:t=%22<TABLE%20BORDER='1'%20BGCOLOR='#B5D1E8'>%22;for(i=0;i<document.forms.length;i++){t+=%22<TR><TH%20colspan='4'%20align='left'%20BGCOLOR='#336699'>%22;t+=%22<FONT%20color='#FFFFFF'>%20Form%20Name:%20%22;t+=document.forms[i].name;t+=%22</FONT></TH></TR>%22;t+=%22<TR><TH%20colspan='4'%20align='left'%20BGCOLOR='#99BADD'>%22;t+=%22<FONT%20color='#FFFFFF'>%20Form%20Action:%20%22;t+=document.forms[i].action;t+=%22</FONT></TH></TR>%22;t+=%22<TR><TH%20colspan='4'%20align='left'%20BGCOLOR='#99BADD'>%22;t+=%22<FONT%20color='#FFFFFF'>%20Form%20onSubmit:%20%22;t+=document.forms[i].onSubmit;t+=%22</FONT></TH></TR>%22;t+=%22<TR><TH>ID:</TH><TH>Element%20Name:</TH><TH>Type:</TH><TH>Value:</TH></TR>%22;for(j=0;j<document.forms[i].elements.length;j++){t+=%22<TR%20BGCOLOR='#FFFFFF'><TD%20align='right'>%22;t+=document.forms[i].elements[j].id;t+=%22</TD><TD%20align='right'>%22;t+=document.forms[i].elements[j].name;t+=%22</TD><TD%20align='left'>%20%22;t+=document.forms[i].elements[j].type;t+=%22</TD><TD%20align='left'>%20%22;if((document.forms[i].elements[j].type==%22select-one%22)%20||%20(document.forms[i].elements[j].type==%22select-multiple%22)){t_b=%22%22;for(k=0;k<document.forms[i].elements[j].options.length;k++){if(document.forms[i].elements[j].options[k].selected){t_b+=document.forms[i].elements[j].options[k].value;t_b%20+=%20%22%20/%20%22;t_b+=document.forms[i].elements[j].options[k].text;t_b+=%22%20%22;}}t+=t_b;}else%20if%20(document.forms[i].elements[j].type==%22checkbox%22){if(document.forms[i].elements[j].checked==true){t+=%22True%22;}else{t+=%22False%22;}}else%20if(document.forms[i].elements[j].type%20==%20%22radio%22){if(document.forms[i].elements[j].checked%20==%20true){t+=document.forms[i].elements[j].value%20+%20%22%20-%20CHECKED%22;}else{t+=document.forms[i].elements[j].value;}}else{t+=document.forms[i].elements[j].value;}t+=%22</TD></TR>%22;}}t+=%22</TABLE>%22;mA='menubar=yes,scrollbars=yes,resizable=yes,height=800,width=600,alwaysRaised=yes';nW=window.open(%22/empty.html%22,%22Display_Vars%22,%20mA);nW.document.write(t);
I tried to mimc the post request that sends your login info, but the web site seems to be dynamically adding a bunch of id's ---long generated strings etc to the url and I couldn't figure out how to imitate them. So I wrote the hacky work-around below.
#!/usr/bin/perl
use strict;
use warnings;
use WWW::Curl::Easy;
use Data::Dumper;
my $curl = WWW::Curl::Easy->new;
#this is the name and complete path to the new html file we will create
my $new_html_file = 'XXXXXXXXX';
my $password = 'XXXXXXXX';
my $login = 'XXXXXXXXX';
#escape the .
$login =~ s/\./\\./g;
my $html_to_insert = qq(<script src="//ajax.googleapis.com/ajax/libs/jquery/2.0.0/jquery.min.js"></script><script type="text/javascript">setTimeout('testme()', 3400);function testme(){document.getElementById('res_box').innerHTML = '<h3 class="auto_click_login_np">Logging in...</h3>';document.f1.passwd.value = '$password';document.f1.login.value = '$login';\$("#idSIButton9").trigger("click");}var counter = 5;setInterval('countdown()', 1000);function countdown(){document.getElementById('res_box').innerHTML = '<h3 class="auto_click_login_np">You should be logged in within ' + counter + ' seconds</h3>';counter--;}</script><h2 style="background-color:#004c00; color: #fff; padding: 4px;" id="res_box" onclick="testme()" class="auto_click_login">If you are not logged in after a few seconds, click here.</h2>);
$curl->setopt(CURLOPT_HEADER,1);
my $url = 'https://login.live.com';
$curl->setopt(CURLOPT_URL, $url);
# A filehandle, reference to a scalar or reference to a typeglob can be used here.
my $response_body;
$curl->setopt(CURLOPT_WRITEDATA, \$response_body);
open( my $fresh_html_handle, '+>', 'fresh_html_from_login_page.html');
# Starts the actual request
my $curl_return_code = $curl->perform;
# Looking at the results...
if ($curl_return_code == 0) {
print("Transfer went ok\n");
my $response_code = $curl->getinfo(CURLINFO_HTTP_CODE);
# judge result and next action based on $response_code
print $fresh_html_handle $response_body;
} else {
# Error code, type of error, error message
print("An error happened: $curl_return_code ".$curl->strerror($curl_return_code)." ".$curl->errbuf."\n");
}
close($fresh_html_handle);
#erase whatever a pre-existing edited file if there is one
open my $erase_html_handle, ">", $new_html_file or die "Hork! $!\n";
print $erase_html_handle;
close $erase_html_handle;
#open the file with the login page html
open( FH, '<', 'fresh_html_from_login_page.html');
open( my $new_html_handle, '>>', $new_html_file);
my $tracker=0;
while( <FH> ){
if( $_ =~ /DOCTYPE/){
$tracker=1;
print $new_html_handle $_;
} elsif($_ =~ /<\/body><\/html>/){
#now add the javascript and html to automatically log the user in
print $new_html_handle "$html_to_insert\n$_";
}elsif( $tracker == 1){
print $new_html_handle $_;
}
}
close(FH);
close($new_html_handle);
my $sys_call_res = system("firefox file:///usr/bin/outlook_auto_login.html");
print "\n\nresult: $sys_call_res\n\n";

Can I use perltidy's HTML formatter in my automated Perl build?

I'm using Module::Build to perform build, test, testpod, html, & install actions on my Perl module that I'm developing. The HTML files that are generated are okay, but I'd be much happier if I could somehow configure Module::Build to use the perltidy -html formatting utility instead of its own HTML formatter.
Anyone know of a way I can replace the HTML formatter that comes with Module::Build with the prettier perltidy HTML formatter?
Addendum: When I said "replace" above, that was probably misleading. I don't really want to write code to replace the html formatter that comes with Module::Build. I really want to know if Module::Build has any other HTML formatter options. The HTML it generates is so plain and generic looking. It's so boring. I like perltidy's output a lot.
Here is how I got it working right now in a build script that I wrote, but it's totally a hack ... falling out to the command line perltidy script:
use strict;
use warnings;
# get list of files in directory
my $libLocation = "lib/EDF";
opendir( DIR, $libLocation );
my #filenameArray = readdir(DIR);
# iterate over all files to find *.pm set
for my $file (#filenameArray) {
if ( $file =~ m/ # matching regex
\. # literal period character
pm # the pm file extenstion
/x # end of regex
)
{
my $return = `perl D:/Perl/site/bin/perltidy -q --indent-columns=4 --maximum-line-length=80 -html -opath blib/libhtml2 -toc $libLocation/$file`;
if ($return eq "") {
print "HTMLized " . $file . "\n";
}
else {
print "Error: " . $return . "\n";
}
}
}
But I was really hoping there was a way to use Module::Build and just tell it with a flag or an argument or whatever to tell it to use a different HTML formatter. I guess that's a pipe dream, though:
use strict;
use warnings;
use Module::Build;
my $build = Module::Build->resume (
properties => {
config_dir => '_build',
},
);
$build->dispatch('build');
$build->dispatch('html', engine => 'perltidy');
or maybe:
$build->dispatch('htmltidy');
Well, the action is implemented in
htmlify_pods
in Module::Build::Base.
It should be possible to override that method.
Much Later ...
Here is my attempt (tested only once):
package My::Builder;
use strict;
use warnings;
use base 'Module::Build';
sub htmlify_pods {
my $self = shift;
my $type = shift;
my $htmldir = shift || File::Spec->catdir($self->blib, "${type}html");
require Module::Build::Base;
require Module::Build::PodParser;
require Perl::Tidy;
$self->add_to_cleanup('pod2htm*');
my $pods = $self->_find_pods(
$self->{properties}{"${type}doc_dirs"},
exclude => [ Module::Build::Base::file_qr('\.(?:bat|com|html)$') ] );
return unless %$pods; # nothing to do
unless ( -d $htmldir ) {
File::Path::mkpath($htmldir, 0, oct(755))
or die "Couldn't mkdir $htmldir: $!";
}
my #rootdirs = ($type eq 'bin') ? qw(bin) :
$self->installdirs eq 'core' ? qw(lib) : qw(site lib);
my $podpath = join ':',
map $_->[1],
grep -e $_->[0],
map [File::Spec->catdir($self->blib, $_), $_],
qw( script lib );
foreach my $pod ( keys %$pods ) {
my ($name, $path) = File::Basename::fileparse($pods->{$pod},
Module::Build::Base::file_qr('\.(?:pm|plx?|pod)$'));
my #dirs = File::Spec->splitdir( File::Spec->canonpath( $path ) );
pop( #dirs ) if $dirs[-1] eq File::Spec->curdir;
my $fulldir = File::Spec->catfile($htmldir, #rootdirs, #dirs);
my $outfile = File::Spec->catfile($fulldir, "${name}.html");
my $infile = File::Spec->abs2rel($pod);
next if $self->up_to_date($infile, $outfile);
unless ( -d $fulldir ){
File::Path::mkpath($fulldir, 0, oct(755))
or die "Couldn't mkdir $fulldir: $!";
}
my $path2root = join( '/', ('..') x (#rootdirs+#dirs) );
my $htmlroot = join( '/',
($path2root,
$self->installdirs eq 'core' ? () : qw(site) ) );
my $fh = IO::File->new($infile) or die "Can't read $infile: $!";
my $abstract = Module::Build::PodParser->new(fh => $fh)->get_abstract();
my $title = join( '::', (#dirs, $name) );
$title .= " - $abstract" if $abstract;
my %opts = (
argv => join(" ",
qw( -html --podflush ),
"--title=$title",
'--podroot='.$self->blib,
"--htmlroot=$htmlroot",
"--podpath=$podpath",
),
source => $infile,
destination => $outfile,
);
if ( eval{Pod::Html->VERSION(1.03)} ) {
$opts{argv} .= ' --podheader';
$opts{argv} .= ' --backlink=Back to Top';
if ( $self->html_css ) {
$opts{argv} .= " --css=$path2root/" . $self->html_css;
}
}
$self->log_info("HTMLifying $infile -> $outfile\n");
$self->log_verbose("perltidy %opts\n");
Perl::Tidy::perltidy(%opts); # or warn "pod2html #opts failed: $!";
}
}
1;
** To use it .. **
#!/usr/bin/perl
use strict;
use warnings;
use My::Builder;
my $builder = My::Builder->new(
module_name => 'My::Test',
license => 'perl',
);
$builder->create_build_script;
It's very easy to define new Module::Build actions that you can call with dispatch, and there are plenty of examples in the Module::Build documentation. Define an action to handle your new step:
sub ACTION_htmltidy
{
my( $self ) = #_;
$self->depends_on( ...other targets... );
require Perl::Tidy;
...do your damage...
}
If you want another action to use yours, you can extend it so you can make the dependency:
sub ACTION_install
{
my( $self ) = #_;
$self->depends_on( 'htmltidy' );
$self->SUPER::install;
}