Not sure if this issue 'belongs' to this group, as I'm not too sure
what is wrong....

I'm using XAMPP which has mod_perl support.

My perl script is located under cgi-bin and is activated from a push
button on a web page, simple so far....

The perl script extracts information from some text files and uses
hash t o store the information. Once the all the text files have been
processed the perl script populates the MYSQL database and then hands
back to a form to allow the user to search through the database.

The issue I face is that everything works fine on the first pass, but
on a 2nd pass through the perl script the hash is empty when I come to
try to populate the database.
I've done some debug and found that the building of the hash still
works fine.

If I make a minor change to the perl script, add a line etc and save
again then it works first press, but not on 2nd :-(

I'm thinking it has some thing to do with the way mod_perl runs
scripts?

Or maybe its some perl type issue???

Any greatfully received

Steve

The script is shown below.....
#!c:/Perl/bin/perl

use strict;
use warnings;
use diagnostics;

use File::Find;
use Data:umper;
use CGI;
use DBI();
use Logger::Logger;

my $protocol;
my $test_name;
my $requirement;
my $title;
my $description;
my $test_step;
my $dependancy;
my @script;
my %testDirectorHash;
my %testhash;
my $master_count = 0;


my $cgi = new CGI;
my $debug_file = 'c:/temp/foo.log';
my $logger;
eval { $logger = new Logger::Logger ( $debug_file ) };
die $@ if $@;

sub currentTime {
my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
my @weekDays = qw(Sun Mon Tue Wed Thu Fri Sat Sun);
(my $second, my $minute, my $hour, my $dayOfMonth, my $month, my
$yearOffset, my $dayOfWeek, my $dayOfYear, my $daylightSavings) =
gmtime();
my $year = 1900 + $yearOffset;
my $theTime = "$hour:$minute:$second, $weekDays[$dayOfWeek]
$months[$month] $dayOfMonth, $year \n";
print $cgi->h4($theTime);
}

sub wanted {
if ( $File::Find::name =~ m/(\.svn)/ ) {
# not a valid test case
} else {
if ($_ =~ m/(\_[A-B]?F\_)(\d*)/ ) {
# my $name = $_;
# my $msg = "Inside if loop in wanted...file is $name";
# $logger->debug_message ($msg);

# correct format
open FHANDLE, "< $_" or die "Cant open $_ : $!";
while (my $line = <FHANDLE> ) {
# remove \n from end
chomp($line);

#find protocol
if ($line =~ m/^(sub\s)/) {
my @test_name = split(/ /,$line);
$test_name = $test_name[1];
$test_name =~ m/(.*)(\_[A-B]?F\_)/;
$protocol = $1;
# my $msg = "found protocol...it is $protocol";
# $logger->debug_message ($msg);
}


# find test requirement
if ( $line =~ m/(=head2(\s*)REQUIREMENT)/ ) {
my $loop = 1;
while ( $loop ) {
if ( $line =~ m/^(=item(\s*))/ ) {
$requirement = (split(/=item/,$line))[1];
my $loop2 = 1;
while ( $loop2 ) {
$line = <FHANDLE>;
chomp($line);
if ($line =~ m/^(\s*)$/) {
$loop2 = 0;
$loop = 0;
} else {
$requirement = $requirement . " " . $line;
}
}
}
$line = <FHANDLE>;
chomp($line);
}
$requirement =~ s/<|>//g;
$requirement =~ m/^\s(.*)/;
$requirement = $1;
# my $msg = "Requirement found and is...$requirement";
# $logger->debug_message ($msg);

}

# find test title
if ( $line =~ m/(=head3(\s*)Title)/ ) {
my $loop = 1;
while ( $loop ) {
if ( $line =~ m/^(=item(\s*))/ ) {
$title = (split(/=item/,$line))[1];
my $loop2 = 1;
while ( $loop2 ) {
$line = <FHANDLE>;
chomp($line);
if ($line =~ m/^(\s*)$/) {
$loop2 = 0;
$loop = 0;
} else {
$title = $title . " " . $line;
}
}
}
$line = <FHANDLE>;
chomp($line);
}
$title =~ s/<|>//g;
# my $msg = "Title found and is...$title";
# $logger->debug_message ($msg);
}

# find Test Description
if ( $line =~ m/(=head3(\s*)Description)/ ) {
my $loop = 1;
while ( $loop ) {
if ( $line =~ m/^(=item(\s*))/ ) {
$description = (split(/=item/,$line))[1];
my $loop2 = 1;
while ( $loop2 ) {
$line = <FHANDLE>;
chomp($line);
if ($line =~ m/^(\s*)$/) {
$loop2 = 0;
$loop = 0;
} else {
$line =~ s/^\s+//g;
$description =$description . " " .
$line;
}
}
}
$line = <FHANDLE>;
chomp($line);
}
# remove <> from start and end
$description =~ s/<|>//g;
# my $msg = "Description found and is...$description";
# $logger->debug_message ($msg);
} # end of find description

# Find Ladder Diagram
if ( $line =~ m/^(\s*)UTT(\s*)SUT/ ) {
my $loop = 1;
my $count = 0;
while ( $loop ) {
$line = <FHANDLE>;
if ($line =~ m/=head3 System Under Test/) {
# found end of ladder diagram stop looping
$loop = 0;
} elsif (index ($line, '---') != -1 ) # find
message arrow
{
# Arrow from ladder diagram goes into
%INCLUDE::mainConstant::testhash{$test_name}{$coun t}{'arrow'}
# Words from ladder diagram go into
%INCLUDE::mainConstant::testhash{$test_name}{$coun t}{'test_step'}
chomp($line);
$testhash{$test_name}{$count}{'arrow'} = $line;
$testhash{$test_name}{$count}{'test_step'} =
$test_step;
$test_step = "";
$count++;
} else {
if ($line =~ m/^(\s*)$/) {
# remove empty lines
} else {
# $test_step will hold words from ladder diagram
$line =~ s/^\s+#?//g; # remove tabs
etc from start of line
$test_step = $test_step . $line;
}
}
}
}
} # end of gather information from script
my $step_count = 0;
# reset file pointer to start and get whole script into array
seek(FHANDLE,0,0);
@script = <FHANDLE>;
close(FHANDLE);
$testDirectorHash{$protocol}{$test_name}{'requirem ent'} =
$requirement;
$testDirectorHash{$protocol}{$test_name}{'title'} =
$title;
$testDirectorHash{$protocol}{$test_name}{'descript ion'} =
$description;
$testDirectorHash{$protocol}{$test_name}{'script'} = "@script";
$master_count++; # keeps track of number of testcases
}
}# end of main if within sub wanted
my $hash = Dumper(%testDirectorHash);
$logger->debug_message ($hash);

}





my @directories_to_search = $cgi->param('tc_location');

#currentTime();

find(\&wanted, @directories_to_search);

# Connect to the database.
my $dbh = DBI->connect("DBI:mysql:database=local_db;host=localho st",
"user", "password",
{'RaiseError' => 1});
#print $cgi->header;
#print $cgi->start_html("bob");

# if (!$dbh) {
# print $cgi->h4('did not connect');
# } else {
# print $cgi->h4('Connected');
# }
my $hash = Dumper(%testDirectorHash);
$logger->debug_message ($hash);

$dbh->do("DROP TABLE IF EXISTS protocol;");
$dbh->do("CREATE TABLE `protocol`
(`protocol_id` int(3) NOT NULL AUTO_INCREMENT PRIMARY KEY,
`protocol_name` varchar(15) character set ascii NOT NULL,
UNIQUE (`protocol_name`));"
);

$dbh->do("DROP TABLE IF EXISTS test_protocol;");
$dbh->do("CREATE TABLE `test_protocol` (
`protocol_id` INT( 3 ) NOT NULL ,
`test_id` INT( 11 ) NOT NULL);"
);
$dbh->do("ALTER TABLE `test_protocol` ADD PRIMARY KEY
( `protocol_id` , `test_id` ) ;");

$dbh->do("DROP TABLE IF EXISTS testcase;");
$dbh->do("CREATE TABLE `testcase` (
`test_id` INT NOT NULL AUTO_INCREMENT PRIMARY KEY ,
`test_name` VARCHAR( 25 ) CHARACTER SET ascii COLLATE
ascii_general_ci NOT NULL ,
`test_title` VARCHAR( 100 ) CHARACTER SET ascii COLLATE
ascii_general_ci NOT NULL ,
`test_description` VARCHAR( 1000 ) CHARACTER SET ascii COLLATE
ascii_general_ci NOT NULL ,
`test_script` VARCHAR( 10000 ) CHARACTER SET ascii COLLATE
ascii_general_ci NOT NULL ,
UNIQUE (`test_name` , `test_title`));"
);

$dbh->do("DROP TABLE IF EXISTS requirement;");
$dbh->do("CREATE TABLE `requirement` (
`req_id` INT( 3 ) NOT NULL AUTO_INCREMENT PRIMARY KEY ,
`req_name` VARCHAR( 50 ) NOT NULL ,
UNIQUE (`req_name`));"
);

foreach my $protocol (keys %testDirectorHash) {
print $cgi->h4("$protocol");
my $msg = "foreach protocol and is...$protocol";
$logger->debug_message ($msg);
my $sth = $dbh->do("INSERT INTO protocol SET protocol_name =
'$protocol';");
}

foreach my $protocol (keys %testDirectorHash) {
foreach my $testname (keys %{$testDirectorHash{$protocol}}) {
my $title = $testDirectorHash{$protocol}{$testname}{'title'};
$title =~ s/'/"/g;
my $description = $testDirectorHash{$protocol}{$testname}
{'description'};
$description =~ s/'/"/g;
my $script = $testDirectorHash{$protocol}{$testname}{'script'};
$script =~ s/'/"/g;
my $msg = "foreach testname found and is...$testname";
$logger->debug_message ($msg);
my $sth = $dbh->do("INSERT INTO testcase SET test_name =
'$testname',
test_title = '$title',
test_description = '$description',
test_script = '$script';");

#retrieve test_id of the inserted testcase
my @id = $dbh->selectrow_array("SELECT LAST_INSERT_ID()");

#find protocol id for this test
my $sth = $dbh->prepare("SELECT protocol_id FROM protocol WHERE
protocol_name = '$protocol';");
$sth->execute();
my $ref = $sth->fetchrow_hashref();
my $prot_id = $ref->{'protocol_id'};

# populate test_protocol with protocol_id and test_id pairs
my $sth = $dbh->do("INSERT IGNORE INTO test_protocol SET protocol_id
= '$prot_id', test_id = '$id[0]';");
}
}
foreach my $protocol (keys %testDirectorHash) {
foreach my $testname (keys %{$testDirectorHash{$protocol}}) {
my $requirement = $testDirectorHash{$protocol}{$testname}
{'requirement'};
$requirement =~ s/'/"/g;
my $sth = $dbh->do("INSERT INTO requirement SET req_name =
'$requirement' ON DUPLICATE KEY UPDATE req_name = '$requirement';");
}
}
# my $sth = $dbh->prepare("SELECT * FROM user");
# $sth->execute();
# while (my $ref = $sth->fetchrow_hashref()) {
# print $cgi->h4("Found a row: id = $ref->{'id'}, name = $ref-
>{'name'}");
# }

# my $sth = $dbh->prepare("SELECT * FROM protocol");
# $sth->execute();
# while (my $ref = $sth->fetchrow_hashref()) {
# print $cgi->h4("Found a row: id = $ref->{'protocol_id'}, name =
$ref->{'protocol_name'}");
# }

# my $sth = $dbh->prepare("SELECT * FROM testcase");
# $sth->execute();
# while (my $ref = $sth->fetchrow_hashref()) {
# print $cgi->h4("Found a row: id = $ref->{'test_id'},
# name = $ref->{'test_name'},
# title = $ref->{'test_title'},
# description = $ref->{'test_description'},
# requirement = $ref->{'test_req'}");
# }
# $sth->finish();

# Disconnect from the database.
$dbh->disconnect();

#print $cgi->end_html;

$cgi->redirect('http://localhost/dir/form.php');
# Tell the webserver everything is fine
#exit (0);

"steve" <steven.stone4@btopenworld.com> schreef in bericht
news:1171526149.787263.196420@a75g2000cwd.googlegr oups.com...
> Not sure if this issue 'belongs' to this group,
Most unlikely ...

> as I'm not too sure what is wrong....
.... but that line always works for me ;-0

> If I make a minor change to the perl script, add a line etc and save
> again then it works first press, but not on 2nd :-(
Just mod_perl noticing the change (by timestamp) and recompiling ONCE,
second throw uses no new dice

> I'm thinking it has some thing to do with the way mod_perl runs
> scripts?
Mod_perl make a script persistent: it compiles ONCE then reuses the program
a configed number of times. Side effect of reusing is not resetting
variables at the next run.

The script needs to be even more strict than strict can tell ...

Example
my $time=time()
print ShowTime;

sub ShowTime{
print scalar $time;
}

will keep printing the time of the first run, untill you change the code to
my $time=time()
print ShowTime($time);

sub ShowTime{
my $showtime = shift @_
print scalar $showtime;
}

Enjoy ...

HansH

On Feb 15, 9:17 am, "HansH" <h...@invalid.invalid> wrote:
> "steve" <steven.sto...@btopenworld.com> schreef in berichtnews:1171526149.787263.196420@a75g2000cwd.g ooglegroups.com...> Not sure if this issue 'belongs' to this group,
>
> Most unlikely ...
>
> > as I'm not too sure what is wrong....
>
> ... but that line always works for me ;-0
>
> > If I make a minor change to the perl script, add a line etc and save
> > again then it works first press, but not on 2nd :-(
>
> Just mod_perl noticing the change (by timestamp) and recompiling ONCE,
> second throw uses no new dice
>
> > I'm thinking it has some thing to do with the way mod_perl runs
> > scripts?
>
> Mod_perl make a script persistent: it compiles ONCE then reuses the program
> a configed number of times. Side effect of reusing is not resetting
> variables at the next run.
>
> The script needs to be even more strict than strict can tell ...
>
> Example
> my $time=time()
> print ShowTime;
>
> sub ShowTime{
> print scalar $time;
> }
>
> will keep printing the time of the first run, untill you change the code to
> my $time=time()
> print ShowTime($time);
>
> sub ShowTime{
> my $showtime = shift @_
> print scalar $showtime;
> }
>
> Enjoy ...
>
> HansH

Thanks for the pointer about, variables not being re-initialised on
2nd pass, have re-worked my script to refer to hash by reference
rather than directly, works great now.

cheers

Steve