I am searching for HF50(HF$HF) for example in "MyFile.txt" so that the extracted data must save to "save.txt". The data on "save.txt" now extracted again and fill the parameters and output on my table. But when I tried the code, I've got no output and "save.txt" is blank.?
Var $HF is not recognized whatever I type. Please help.
#! /usr/bin/perl
print "Content-type:text/html\r\n\r\n";
use CGI qw(:standard);
use strict;
use warnings;
my ($file,$line,$tester,$HF,$keyword);
my ($f1,$f2,$f3,$f4,$f5,$f6,$f7,$f8,$f9,$f10,$f11,$f12,$f13,$f14,$f15,$f16,$f17,$f18,$f19);
my $keyWord=param('keyword');
$HF=$keyWord;
my $infile='MyFile.txt';
my $outfile='save.txt';
open (my $inhandle, '<',$infile) or die "Can't open $infile:$!";
open (my $outhandle, '>', $outfile) or die "Can't open $outfile:$!";
while (my $line=<$inhandle>){
if ($line=~ m/HF$HF/i) {
print {$outhandle}$line;
print $line;
print "<HTML>";
print "<head>";
print "<body bgcolor='#4682B4'>";
print "<title>FUSION SHIFT REPORT</title>";
print "<div align='left'>";
print "<FORM METHOD='get' ACTION='http://Shielex.com/pe/mrigos/mainhead.html'>";
print "<b>SEACRH:</b>";
print "<INPUT TYPE='text' NAME='rec' SIZE='12' MAXLENGHT='40'>";
print "<INPUT TYPE='submit' value='go'>";
print "</form>";
print "<TABLE CELLPADDING='1' CELLSPACING='1' BORDER='1' bordercolor=black width='100%'>";
print "<TR>";
print "<td width='11%'bgcolor='#00ff00'><font size='2'>TESTER No.</td>";
print "<td width='10%'bgcolor='#00ff00'><font size='2'>DATE</td>";
print "<td width='11%'bgcolor='#00ff00'><font size='2'>DEVICE NAME</td>";
print "<td bgcolor='#00ff00'><font size='2'>TEST PROGRAM</td>";
print "<td width='10%'bgcolor='#00ff00'><font size='2'>SMSLOT</td>";
print "<td width='12%'bgcolor='#00ff00'><font size='2'>LOADBOARD</td>";
print "<td width='10%'bgcolor='#00ff00'><font size='2'>CATEGORY</td>";
print "<td width='13%'bgcolor='#00ff00'><font size='2'>ROOT CAUSE 1</td>";
print "<td width='13%'bgcolor='#00ff00'><font size='2'>ROOT CAUSE 2</td>";
print "</tr>";
print "<TR>";
$file='save.txt';
open(F,$file)||die("Could not open $file");
while ($line=<F>)
{
my #cells=($f1,$f2,$f3,$f4,$f5,$f6,$f7,$f8,$f9,$f10,$f11,$f12,$f13,$f14,$f15,$f16,$f17,$f18,$f19)= split ',',$line;
print "<TD bgcolor='#ADD8E6'><font size='2'>$f2</TD>";
print "<TD bgcolor='#ADD8E6'><font size='2'>$f3</TD>";
print "<TD bgcolor='#ADD8E6'><font size='2'>$f5</TD>";
print "<TD bgcolor='#ADD8E6'><font size='2'>$f6</TD>";
print "<TD bgcolor='#ADD8E6'><font size='2'>$f8</TD>";
print "<TD bgcolor='#ADD8E6'><font size='2'>$f10</TD>";
print "<TD bgcolor='#ADD8E6'><font size='2'>$f17</TD>";
print "<TD bgcolor='#ADD8E6'><font size='2'>$f18</TD>";
print "<TD bgcolor='#ADD8E6'><font size='2'>$f19</TD>";
print "</tr>";
}
}
}
close F;
print "</TABLE>";
print "</body>";
print "<html>";
=MyFile.txt data=
1,HF50,13-OCT-08,04:17:53,761503BZZGR-62,B2761503BP22.EVA,DWP,DWP,Calibration
2,HF60,13-OCT-08,04:17:53,761503BZZGR-62,B2761503BP22.EVA,DWP,DWP,Calibration
1,HF50,13-OCT-08,04:17:53,761503BZZGR-62,B2761503BP22.EVA,DWP,DWP,Calibration
Are you running this as a CGI script? In that case, you probably don't have permission to open a file for writing. Did you check the error log to see if your message from die is in there?
You might want to check out Troubleshooting Perl CGI scripts. Go through all of the steps without skipping any. When you get stuck, you have most of the imformation you need to help us help you.
Good luck, :)
You never close $outfile so it doesn't get flushed. But maybe you want to store the data in an array instead?
As an aside, you should always use the three-argument form of open() and you should also always use absolute paths when working with CGI programs, as in many situations, the "current directory" is not what you think it is.
First, Perl's output is by nature buffered. So, unless you use some explicit method, there's no guarantee that the physical file will have anything to read. As somebody mentioned, you'll have to flush the output somehow. My comments are below in the code. (You could also do this by closing the output file and opening it in append mode after you've read from it.)
Second, it doesn't seem like you want to do what it looks like you want to do. If everything was flushed perfectly to the file, you're requesting an html header per input line. So as I added lines into the input, it printed out that many search boxes. I don't expect that is what you wanted.
Here's a more perl-ified code:
use CGI qw(:standard);
use IO::File;
use strict;
use warnings;
my ($file,$line,$HF); #,$tester,$HF,$keyword);
# don't pollute -> my ($f1,$f2,$f3,$f4,$f5,$f6,$f7,$f8,$f9,$f10
# ,$f11,$f12,$f13,$f14,$f15,$f16,$f17,$f18,$f19);
# my $keyWord=param('keyword'); <-- if you're not going to do anything with $keyWord
$HF=param('keyword'); # <- assign it to the variable you're going to use
my $infile='MyFile.txt';
my $outfile='save.txt';
open (my $inhandle, '<',$infile) or die "Can't open $infile:$!";
open (my $outhandle, '>', $outfile) or die "Can't open $outfile:$!";
# this would flush -> my $outhandle = IO::File->new( ">$outfile" );
print q{Content-type:text/html
<HTML>
<head>
<title>FUSION SHIFT REPORT</title>
<style type="text/css">
.header { background-color : #0f0; font-size : 12pt }
.detail { background-color : #ADD8E6; font-size : 12pt }
</style>
</head>
<body bgcolor='#4682B4'>
<div align='left'>
<FORM METHOD='get' ACTION='http://Shielex.com/pe/mrigos/mainhead.html'>
<b>SEACRH:</b>
<input type='text' name='rec' size='12' maxlenght='40'>
<input type='submit' value='go'>
</form>
<table cellpadding='1' cellspacing='1' border='1' bordercolor=black width='100%'>
<tr>
<td class="header" width='11%'>TESTER No.</td>
<td class="header" width='10%'>DATE</td>
<td class="header" width='11%'>DEVICE NAME</td>
<td class="header" >TEST PROGRAM</td>
<td class="header" width='10%'>SMSLOT</td>
<td class="header" width='12%'>LOADBOARD</td>
<td class="header" width='10%'>CATEGORY</td>
<td class="header" width='13%'>ROOT CAUSE 1</td>
<td class="header" width='13%'>ROOT CAUSE 2</td>
</tr>
};
my $hf_str = ",HF$HF,";
# OO -> $outhandle->autoflush(); <- set autoflush
while (my $line=<$inhandle>){
next unless index( $line, $hf_str ) > -1;
# OO -> $outhandle->print( $line );
# $outhandle->flush(); <- if autoflush not set, do it manually
print *{$outhandle} $line;
print "<tr>"
, ( map { qq{<td class="detail">$_</td>} }
split ',', $line
)
, "</tr>\n"
;
}
print q{
</table>
</body>
</html>
};
Related
Every time I refresh my page an empty session gets created.
Index.cgi
#!perl.exe
use strict;
use warnings;
use DBI;
use CGI;
use database;
use Digest::MD5 qw(md5 md5_hex md5_base64);
use Data::Dumper;
use CGI::Session;
my $q = new CGI;
my $session = new CGI::Session();
my $db=database->new();
print $q->header;
$session = CGI::Session->load();
my $first_name = $session->param("userid");
my $login_fail=$q->param("attempt");
<div class='login_form' style=''>
<form method='post' action='Session.cgi'>
<table>
END_HTML
if ($session->is_empty)
{
print <<END_HTML;
<tr class='l_form_input'>
<td><input type='text' name='userid' placeholder='Email or Phone'/></td>
<td><input type='password' name='password' placeholder='Password'/></td>
<td><input type='submit' name='submit' value='Log In'/></td>
</tr>
<tr>
<td><span><a href='reg.cgi'>Not A Member Yet?</a></span></td>
<td><span><a href='forgot.cgi'>Forget your password?</a></span></td>
</tr>
END_HTML
if (defined($login_fail)) {
print "<tr><td colspan='2'>Incorrect Login<td></tr>";
}
}else {
print <<END_HTML;
<tr class='l_form_input'>
<td><span>Logged in as $first_name</span></td>
<td><span><a href='logout.cgi'>logout<span></a></td>
</tr>
END_HTML
}
print <<END_HTML;
</table>
</form>
</div>
Session.cgi
#!perl.exe
use strict;
use warnings;
use database;
use DBI;
use CGI;
use Digest::MD5 qw(md5 md5_hex md5_base64);
my $q = new CGI;
my $db=database->new();
#print $q->header;
my $email=$q->param("userid");
my $password=$q->param("password");
$password = md5_hex($password);
my $flag=$db->login_flag($email,$password);
if($flag == 1) {
require CGI::Session;
my $session = CGI::Session->new();
print $session->header();
$session->param("userid", $email);
$session->flush();
print "<META HTTP-EQUIV=refresh CONTENT=\"1;URL='http://localhost/website/index.cgi\">\n";
} else {
print $q->header;
print "<META HTTP-EQUIV=refresh CONTENT=\"1;URL='http://localhost/website/index.cgi?attempt=login_fail\">\n";
}
Pass the CGI object when creating the new CGI::Session:
my $session = CGI::Session->new($q) or die CGI->Session->errstr;
Otherwise, you're just creating an anonymous session each time that is not dependent on the user's information.
I need to scan through html fragments looking for certain strings in text (not within element attributes) and wrapping those matching strings with a <span></span>. Here's a sample attempt with output:
use v5.10;
use Mojo::DOM;
my $body = qq|
<div>
<p>Boring Text:</p>
<p>
Highlight Cool whenever we see it.
but not here.
<code>
sub Cool {
print "Foo\n";
}
</code>
And here is more Cool.
</p>
</div>
|;
my $dom = Mojo::DOM->new($body);
foreach my $e ($dom->find('*')->each) {
my $text = $e->text;
say "e text is: $text ";
if ($text =~ /Cool/) {
(my $newtext = $text ) =~ s/Cool/<span class="fun">Cool<\/span>/g;
$e->replace_content($newtext);
}
}
say $dom->root;
the output:
e text is:
e text is: Boring Text:
e text is: Highlight Cool whenever we see it. but not. And here is more Cool.
e text is: here
e text is: sub Cool { print "Foo "; }
<div>
<p>Boring Text:</p>
<p>Highlight <span class="fun">Cool</span> whenever we see it. but not. And here is more <span class="fun">Cool</span>.</p>
</div>
Close but what I really want to see is something like the following:
<div>
<p>Boring Text:</p>
<p>Highlight <span class="fun">Cool</span> whenever we see it. but not here.
<code>
sub <span class="fun">Cool<span> {
print "Foo\n";
}
</code>
And here is more <span class="fun">Cool</span>.</p>
</div>
Any help / pointers would be greatly appreciated.
Thanks,
Todd
Having looked into XML::Twig I'm not so sure it's the correct tool. It's surprising how awkward such a simple task can be.
This is a working program that uses HTML::TreeBuilder. Unfortunately it doesn't produce formatted output so I've added some whitespace myself.
use strict;
use warnings;
use HTML::TreeBuilder;
my $html = HTML::TreeBuilder->new_from_content(<<__HTML__);
<div>
<p>Boring Text:</p>
<p>
Highlight Cool whenever we see it.
but not here.
<code>
sub Cool {
print "Foo\n";
}
</code>
And here is more Cool.
</p>
</div>
__HTML__
$html->objectify_text;
for my $text_node ($html->look_down(_tag => '~text')) {
my $text = $text_node->attr('text');
if (my #replacement = process_text($text)) {
my $old_node = $text_node->replace_with(#replacement);
$old_node->delete;
}
}
$html->deobjectify_text;
print $html->guts->as_XML;
sub process_text {
my #nodes = split /\bCool\b/, shift;
return unless #nodes > 1;
my $span = HTML::Element->new('span', class => 'fun');
$span->push_content('Cool');
for (my $i = 1; $i < #nodes; $i += 2) {
splice #nodes, $i, 0, $span->clone;
}
$span->delete;
#nodes;
}
output
<div>
<p>Boring Text:</p>
<p>
Highlight <span class="fun">Cool</span> whenever we see it.
but not here.
<code> sub <span class="fun">Cool</span> { print "Foo "; } </code>
And here is more <span class="fun">Cool</span>.
</p>
</div>
Here is a start using XML::Twig. One issue is the literal newline inside <code> tag. I guess that the parser cannot see the difference between it and a normal one. Perhaps it would help to encode it as 
 or use CDATA sections. Otherwise I don't know how to handle it:
Content of script.pl:
#!/usr/bin/env perl
use warnings;
use strict;
use XML::Twig;
my $body = qq|
<div>
<p>Boring Text:</p>
<p>
Highlight Cool whenever we see it.
but not here.
<code>
sub Cool {
print "Foo\n";
}
</code>
And here is more Cool.
</p>
</div>
|;
XML::Twig::Elt::set_replaced_ents(q{});
my $elt = XML::Twig::Elt->new( 'span' => { class => 'fun' }, 'Cool' );
my $twig = XML::Twig->new( pretty_print => 'nice' )->parse( $body );
$twig->subs_text( 'Cool', $elt->sprint );
$twig->print;
Running it like:
perl script.pl
It yields:
<div>
<p>Boring Text:</p>
<p>
Highlight <span class="fun">Cool</span>
whenever we see it.
but not here.
<code>
sub <span class="fun">Cool</span>
{
print "Foo
";
}
</code>
And here is more <span class="fun">Cool</span>
.
</p>
</div>
I have been trying to run a simple perl-cgi script on windows XP. This is a simple HTML form with an Submit button where clicking on Submit button displays some text(Username). But clicking the Submit button on the HTML page, nothing is happening. If I open up browser with url its working fine.
HTML Form:
<form id="form" name="form" method="post" action="C:/Server/Apache2/cgi-bin/hello.cgi" enctype="multipart/form-data">
<h1><center>User Login</center></h1>
<p><label><h4>Username</h4></label>
<input type="text" name="username" id="username" /></p>
<p><label><h4>Password</h4></label>
<input type="password" name="password" id="password" /></p>
<button type="submit">Sign-In</button><br><br>
CGI :
#!C:\perl\bin\perl.exe -wT
local ($buffer, #pairs, $pair, $name, $value, %FORM);
# Read in text
$ENV{'REQUEST_METHOD'} =~ tr/a-z/A-Z/;
if ($ENV{'REQUEST_METHOD'} eq "POST")
{
read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
}else {
$buffer = $ENV{'QUERY_STRING'};
}
# Split information into name/value pairs
#pairs = split(/&/, $buffer);
foreach $pair (#pairs)
{
($name, $value) = split(/=/, $pair);
$value =~ tr/+/ /;
$value =~ s/%(..)/pack("C", hex($1))/eg;
$FORM{$name} = $value;
}
$user_name = $FORM{username};
print "Content-type:text/html\r\n\r\n";
print "<html>";
print "<head>";
print "<title>Hello - Second CGI Program</title>";
print "</head>";
print "<body>";
print "<h2>Hello $user_name - Second CGI Program</h2>";
print "</body>";
print "</html>";
1;
Opening CGI directly in browser:
You need proper URL in form action attribute, ie. action="/cgi-bin/hello.cgi"
Another suggestion just to add.
Since it looks like you are just starting to learn perl, I would read into the CGI module. CGI is a widely used perl module for programming CGI : Common Gateway Interface which is used to recieve user input and produce HTML output. It processes form submissions, query string manipulation, and processing and preparing HTTP headers.
There are two styles of programming with CGI, object-oriented and function-oriented.
I'm trying to achieve one last task for my assignment is to validate the form before submit it to the another CGI program.
What happen is that I have a simple CGI program that will ask user to input the data
#!/usr/bin/perl -w
use CGI qw/:standard/;
# Standard HTTP header
print header();
# Write information to data file and produce a form
&printForm();
# Finish HTML page
print end_html();
# This sub will create a form to access the print_fortune.cgi script
sub printForm
{
print qq~
<html>
<head><title>My Search Engine</title>
</head>
<body>
<form action="b1.cgi" method="GET">
What is your e-msil address? <input type="text" name="passing" size=40>
<input type="submit" value="send address">
<input type="hidden" name="form" value="insert" />
</form>
<form method="get" action="b1.cgi" enctype="application/x-www-form-urlencoded">
<input type="text" name="search" value="" size="30" /><br />
<label><input type="radio" name="option" value="name" checked="checked" />name</label>
<label><input type="radio" name="option" value="author" />author</label><label>
<input type="radio" name="option" value="url" />url</label>
<label><input type="radio" name="option" value="keyword" />keyword</label>
<input type="submit" name=".submit" value="Search" />
<input type="hidden" name="passing" value="http://default.com" />
<div><input type="hidden" name="form" value="search" /></div></form>
</body>
So the above program contains two forms. One is to add new data to the database and the other one is to search from the database.
#!/usr/bin/perl
print "Content-type: text/html\n\n";
use LWP::Simple;
use CGI;
use HTML::HeadParser;
use DBI;
my $serverName = "";
my $serverPort = "";
my $serverUser = "";
my $serverPass = "";
my $serverDb = "";
my $serverTabl = "";
$cgi = CGI->new;
my $pass = $cgi->param('passing');
$URL = get ("$pass");
$head = HTML::HeadParser->new;
$head->parse("$URL");
my $methods = $cgi->param('form');
if ($methods eq "insert"){
insert_entry();
}
show_entries();
sub insert_entry {
my ($dbh, $success, $name, $author, $url,$temp);
$dbh = DBI->connect("DBI:mysql:database=$serverDb;host=$serverName;port=$serverPort",$serverUser,$serverPass);
$name = $head->header('X-Meta-Name');
$author = $head->header('X-Meta-Author');
$url = $cgi->param('passing');
$temp = $head->header('X-Meta-Keywords');
#keyword = split(/,/,$temp);
$success = $dbh->do("INSERT INTO $serverTabl(name,author,url,keyword1,keyword2,keyword3,keyword4,keyword5) VALUES(?,?,?,?,?,?,?,?)", undef,$name,$
author,$url,$keyword[0],$keyword[1],$keyword[2],$keyword[3],$keyword[4]);
$dbh->disconnect;
if($success != 1) {
return "Sorry, the database was unable to add your entry.
Please try again later.";
} else {
return;
}
}
sub show_entries {
my ($dbh, $sth, #row);
my $search = $cgi->param('search');
my $option = $cgi->param('option');
$dbh = DBI->connect("DBI:mysql:database=$serverDb;host=$serverName;port=$serverPort",$serverUser,$serverPass);
$sth = $dbh->prepare("SELECT *
FROM $serverTabl
WHERE $option LIKE '%$search%'");
$sth->execute;
print "Existing Entries",HR;
while(#row = $sth->fetchrow_array) {
$row[5] = scalar(localtime($row[5]));
print "<table border='2'><tr>";
print "<td>" . $row[0] . "</td>";
print "<td>Name" . $row[1] . "</td>";
print "<td>Author" . $row[2] . "</td>";
print "<td>URL" . $row[3] . "</td>";
print "<td>Keyword1" . $row[4] . "</td>";
print "<td>Keyword2" . $row[5] . "</td>";
print "<td>Keyword3" . $row[6] . "</td>";
print "<td>Keyword4" . $row[7] . "</td>";
print "<td>Keyword5" . $row[8] . "</td>";
print "</tr></table>";
}
$sth->finish;
$dbh->disconnect;
}
So now the question is how can I do a regular expression for the form submission before it goes to the second program?
I want to do validation for
name allows spaces but only alphabetical characters
author allows spaces but only alphabetical characters
keywords allows no spaces and only alphabetical characters
url only allows alphanumerical characters and the following :/.~?=+& No two periods can exist consecutively.
I'm really sorry but I'm really new to Perl. We are only been taught about PHP, but Perl almost nothing....
The perluniprops Perl document lists all the \p regular expression properties.
For a string that contains only letters, you want
/^[\p{Alpha}]+$/
For a string that contains only letters and spaces you want
/^[\p{Alpha}\x20]+$/
To match a URL the documentation of the URI module gives this as an official pattern to match a URL
m|^(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?$|
Be sure to cite the references in your work to get extra marks!
I'm writing a script to rearrange html content and I'm stuck with 2 problems. I have this html structure, which is movie titles and release years with thumbnails grouped in 5 columns. I want to generate new html files with the movies grouped by decades from 2011 to 1911, e.g. present-2011; 2010-2001; 2000-1991; etc.
<table>
<tr>
<td class="basic" valign="top">
<a href="details/267226.html" title="" id="thumbimage">
<img src="images/267226f.jpg"/>
</a>
<br/>Cowboys & Aliens (2011)
</td>
<td class="basic" valign="top">
<a href="details/267185.html" title="" id="thumbimage">
<img src="images/267185f.jpg"/>
</a>
<br/>The Hangover Part II (2011)
</td>
<td class="basic" valign="top">
<a href="details/267138.html" title="" id="thumbimage">
<img src="images/267138f.jpg"/>
</a>
<br/>Friends With Benefits (2011)
</td>
<td class="basic" valign="top">
<a href="details/266870.html" title="" id="thumbimage">
<img src="images/266870f.jpg"/>
</a>
<br/>Beauty And The Beast (1991)
</td>
<td class="basic" valign="top">
<a href="details/266846.html" title="" id="thumbimage">
<img src="images/266846f.jpg"/>
</a>
<br/>The Fox And The Hound (1981)
</td>
</tr>
......
</table>
The one problem I have no idea how to solve is that after removing movies not matching the decade I'm left with empty 'tr' tags and thumbnail positions and don't know how to rearrange again every row in 5 columns filled with 5 titles. And also how to process each decade with one call of the script. Thanks.
use autodie;
use strict;
use warnings;
use File::Slurp;
use HTML::TreeBuilder;
my $tree = HTML::TreeBuilder->new_from_file( 'test.html' );
for my $h ( $tree->look_down( class => 'basic' ) ) {
edit_links( $h );
my ($year) = ($h->as_text =~ /.*?\((\d+)\).*/);
if ($year > 2010 or $year < 2001) {
$h->detach;
write_file( "decades/2010-2001.html", \$tree->as_HTML('<>&',' ',{}), "\n" );
}
}
sub edit_links {
my $h = shift;
for my $link ( $h->find_by_tag_name( 'a' ) ) {
my $href = '../'.$link->attr( 'href' );
$link->attr( 'href', $href );
}
for my $link ( $h->find_by_tag_name( 'img' ) ) {
my $src = '../'.$link->attr( 'src' );
$link->attr( 'src', $src );
}
}
The approach below should do what you wanted in question. During the HTML file processing, the hash %decade is setup, each key being ending year of decade and value arrayref of appropriate cells.
Second loop traverses the hash and outputs file for each decade, surrounding each 5 cells with <tr> tag.
use strict;
use HTML::TreeBuilder;
use File::Slurp;
use List::MoreUtils qw(part);
my $tree = HTML::TreeBuilder->new_from_file('test.html');
my %decade = ();
for my $h ( $tree->look_down( class => 'basic' ) ) {
edit_links( $h );
my ($year) = ($h->as_text =~ /.*?\((\d+)\).*/);
my $dec = (int($year/10) + 1) * 10;
$decade{$dec} ||= [];
push #{$decade{$dec}}, $h;
}
for my $dec (sort { $b <=> $a } keys %decade) {
my $filename = "decades/" . $dec . "-" . ($dec - 9) . ".html";
my $idx = 0;
my #items = map { $_->as_HTML('<>&',' ',{}) } #{ $decade{$dec} };
my $contents = join('',
'<table>',
(map { "<tr>#$_</tr>" } part { int($idx++ / 5) } #items),
'</table>');
write_file( $filename, $contents);
}
...