How to trigger Zoneminder to phone a land line - triggers

You need to connect your PC to the land-line via a "modem".
Install wvdial (and configure it) (and test that it rings your phone).
Then modify the script supplied by zoneminder to access the modem (search that page for e.g. "trigger").
Run that script e.g. in your home directory.
Also I discover that modems, being rather old-fashioned, are not well supported in Linux e.g. "Winmodems" (are cheap)because they do low level stuff in (Windows) software to save on hardware hence my old-PC's PCI-modem is not supported any more in current Linux i.e. I had to find a hardware-driven modem e.g. a "Trendnet TFM 561u" instead. This worked out-of-the-box on my Mint 14 system (December 2013) appearing as /dev/ttyACM0.
#!/usr/bin/perl -w
use strict;
use lib ("/opt/zm/share/perl/5.14.2");
use ZoneMinder;
$| = 1;
# mDbgInit( "myscript", level=>0, to_log=>0, to_syslog=>0, to_term=>1 );
my $dbh = DBI->connect( "DBI:mysql:database=".ZM_DB_NAME.";host=".ZM_DB_HOST, ZM_DB_USER, ZM_DB_PASS );
my $sql = "select M.*, max(E.Id) as LastEventId from Monitors as M left join Events as E on M.Id = E.MonitorId where M.Function != 'None' group by (M.Id)";
my $sth = $dbh->prepare_cached( $sql ) or die( "Can't prepare '$sql': ".$dbh->errstr() );
my $res = $sth->execute() or die( "Can't execute '$sql': ".$sth->errstr() );
my #monitors;
while ( my $monitor = $sth->fetchrow_hashref() )
{
push( #monitors, $monitor );
}
while( 1 ) {
foreach my $monitor ( #monitors ) {
next if ( !zmMemVerify( $monitor ) );
my $lei = eval { # avoid...
$monitor->{LastEventId}; # ...aborting
}; # ...this script
warn $# if $#; # ...if there is no
if( ! $lei ) { # ...LastEventId
next; # ...e.g. for a clean start
} # ...after clearing out database.
my $last_event_id = zmHasAlarmed( $monitor, $lei );
if ( $last_event_id ) {
if ( $monitor->{Name} ne "monitor-1" && $monitor->{Name} ne "monitor-2" ) {
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
if ( $hour > 23 || $hour < 7 ) {
$monitor->{LastEventId} = $last_event_id;
print( "Monitor ".$monitor->{Name}." has alarmed \n" );
my $cmd .= "echo ";
$cmd .= "\"";
$cmd .= "Garage Alarm: ".$monitor->{Name};
$cmd .= "\"";
$cmd .= ' | mail -s `curl ifconfig.me` myemailaddress#gmail.com';
system ($cmd);
system('wvdial');
}
}
}
}
sleep( 1 );
}
This is my first attempt at (modifing) Perl. It will be rough!
The first system($cmd) emails me at myemailaddress#gmail.com (you will need to set this up yourself to get mail to work) with the current URL just in case it has recently changed.
The second system('wvdial') rings my phone.
As you can see, "monitor-1" and "monitor-2" are ignored.
As you can see, it is enabled between the hours of just after 11pm to just before 7 am.
My /etc/wvdial.conf file looks similar to this:-
[Dialer Defaults]
Init1 = ATZ
Init2 = ATQ0 V1 E1 S0=0 &C1 &D2 +FCLASS=0
Modem Type = USB Modem
Phone = 123456789
ISDN = 0
Password = <Your Password>
New PPPD = yes
Username = <Your Login Name>
Modem = /dev/ttyACM0
Baud = 460800
Dial Command = ATDT
Auto Reconnect = off
Dial Attempts = 1

Related

Program run under cron creates file in wrong path

I am trying to execute a Perl script using crontab.
Manually, the script works fine, but when I use cron, I get an error
/home/dev/test.csv : not readable
/home/dev/test.csv is a file generated by the script, but it is created as /home/test.csv and
I don't know how or why.
This is my crontab:
/3 * * * * /home/dev/metrique.pl &> /home/dev/output.txt
this is my code :
#!/sw/freetools/perl/5.8.8/Linux/rh50/x86_64/bin/perl
#use strict ;
#use warnings ;
use DBI ;
use DateTime ;
use Text::CSV;
use MIME::Lite;
my $Month = DateTime->now->subtract(months=>0)->truncate(to=>'month') ->strftime('%B') ;
my $Date = DateTime->now->subtract(months=>0)->truncate(to=>'month') ->strftime('%Y-%m') ;
$Date ="%".$Date."%" ;
my %info = (db => "ilico", host => "gnx5910.gnb.st.com", user => "ilicousr", pass => "" );
my $dbh = DBI->connect("DBI:mysql:$info{db};$info{host}", $info{user}, $info{pass});
my #record ;
my %Report;
my #other;
my #region = qw{EMEA AME ASIA INDIA Global-WAN};
my #scope = qw{wan lan specific};
my $total_weekly = 0;
my $total_usage = 0;
my $weekly = '2';
my $usage = '1';
my #top_user ;
my #array ;
my #user ;
my %hash = ();
my %sum = ();
my %LOGIN_W = ();
my %Groupe = ();
my %hash1 = ();
my %Nom_Complet = ();
my %NUMBER = ();
my $filename1="NBgenerated_Reports.csv";
my $filename2="Report_Scope.csv";
my $filename3 ="Top_10_Features.csv";
my $filename4 ="Top_10_Users.csv";
my $filename5 ="/sw/st/itcad/setup/shared_data/ldp_om.csv";
my $filename6 ="Report_Groupe.csv";
open(my $fh1, ">", $filename1) or die "cannot open < $filename1: $!";
open(my $fh2, ">", $filename2) or die "cannot open < $filename2: $!";
open(my $fh3, ">", $filename3) or die "cannot open < $filename3: $!";
open(my $fh4, ">", $filename4) or die "cannot open < $filename4: $!";
open(my $fh5, "<", $filename5) or die "cannot open < $filename5: $!";
open(my $fh6, ">", $filename6) or die "cannot open < $filename6: $!";
print $fh1 "Region; Usage_Report; Weekly; \n";
print $fh2 "Scope; NB; \n";
print $fh3 "Feature; NB; \n";
print $fh4 "User; NB_Report ;Groupe \n";
print $fh6 "Groupe; NB_Report \n";
#usage & weekly
my $sql = qq/SELECT COUNT( `Region`.`RegID` ) FROM `iLico_Log`, `Region` WHERE `iLico_Log`.`Date` LIKE ? AND `Region`.`RegID` = `iLico_Log`.`RegID` AND `iLico_Log`.`Type` = ?
AND `Region`.`RegName` LIKE ? / ;
foreach my $reg (#region){
foreach my $type ($weekly, $usage){
my $sth = $dbh->prepare($sql) or die ("unable to prepare");
$sth->execute(($Date, $type, $reg)) ;
#record = $sth -> fetchrow_array();
$Report{$reg}{$type}=$record[0];
}
}
foreach my $reg (keys %Report) {
$total_usage += $_ for($Report{$reg}{$usage});
$total_weekly += $_ for($Report{$reg}{$weekly});
print $fh1 "$reg ; $Report{$reg}{$usage}; $Report{$reg}{$weekly} \n";
}
print $fh1 "total; $total_usage; $total_weekly; \n";
#scope
my $SCOPE = qq/SELECT COUNT(logID ) FROM `iLico_Log` WHERE `iLico_Log`.`Date` LIKE ? AND `iLico_Log`.`scope`= ?/;
foreach my $sc (#scope){
my $sth = $dbh->prepare($SCOPE) or die ("unable to prepare");
$sth->execute($Date, $sc) ;
my #record = $sth -> fetchrow_array();
print $fh2 "$sc; #record; \n";
}
#Top 10 features
my $TopFeatures = qq/SELECT `Feature`.`FeatName` , COUNT( * ) NB FROM `iLico_Log`, `Feature` WHERE `iLico_Log`.`Date` LIKE ? AND `iLico_Log`.`FeatID` = `Feature`.`FeatID` GROUP BY `Feature`.`FeatID` ORDER BY NB DESC LIMIT 10 /;
my $sth = $dbh->prepare($TopFeatures) or die ("unable to prepare");
$sth->execute($Date) ;
while( #record = $sth -> fetchrow_array())
{
print $fh3 "$record[0]; $record[1]; \n";
}
#other features number
my $Other = qq/SELECT COUNT(DISTINCT `iLico_Log`.`FeatID`) NB FROM `iLico_Log`, `Feature` WHERE `iLico_Log`.`Date` LIKE ? AND `iLico_Log`.`FeatID` = `Feature`.`FeatID`/;
$sth = $dbh->prepare($Other) or die ("unable to prepare");
$sth->execute($Date) ;
#record = $sth -> fetchrow_array();
$other[0] = $record[0] - 10 ;
print $fh3 "Other_features_number; #other \n";
#total usage of all and other features
my $TotalUsage =qq/SELECT COUNT( * ) SU FROM `iLico_Log` , `Feature` WHERE `iLico_Log`.`Date` LIKE ? AND `iLico_Log`.`FeatID` = `Feature`.`FeatID`/;
my $SUMTopFeatures = qq/select sum(NB) from (SELECT `Feature`.`FeatName` , COUNT( * ) NB FROM `iLico_Log`, `Feature` WHERE `iLico_Log`.`Date` LIKE ? AND `iLico_Log`.`FeatID` = `Feature`.`FeatID` GROUP BY `Feature`.`FeatID` ORDER BY NB DESC LIMIT 10) AS subquery /;
$sth = $dbh->prepare($TotalUsage) or die ("unable to prepare");
my $sth1 = $dbh->prepare($SUMTopFeatures) or die ("unable to prepare");
$sth->execute($Date) ;
$sth1->execute($Date) ;
#record = $sth -> fetchrow_array();
my #sum = $sth1 -> fetchrow_array();
$other[0] = $record[0] - $sum[0] ;
print $fh3 "Other_total_usage; #other";
#select login windows and groupe from file ldp_om.csv to be used in top_10_user and nomber Report/Groupe
while (<$fh5>) {
chomp;
my ($mail, $uid, $site, $grp, $dvs, $cnt, $ccost, $mng, $typ, $phone, $first, $last, $login, $cn) = split ';', lc($_), 14;
if (! exists $LOGIN_W{$login}) {
$LOGIN_W{$login} = $grp;
}
if (! exists $hash{$login}) {
$Groupe{$login} = $grp;
$Nom_Complet{$login} = $cn;
}
}
#top 10 user / Groups
my $TopUsers = qq/select ilicoUserLogin, COUNT(*) NB, Display from ilico_log I where Date like ? GROUP BY I.ilicoUserLogin ORDER BY NB DESC LIMIT 10/;
$sth = $dbh->prepare($TopUsers) or die ("unable to prepare");
$sth->execute($Date) ;
while( #top_user = $sth -> fetchrow_array())
{
$top_user[0] =~ s/\s+/ /g;
push (#array, lc($top_user[0]));
my $login = lc($top_user[0]);
$NUMBER{$login} = $top_user[1];
}
foreach my $login ( #array ){
$hash1{$login} = $Groupe{$login};
}
foreach my $login (sort {$NUMBER{$b} <=> $NUMBER{$a}} keys %hash1) {
my $grpe = uc($hash1{$login}) ;
my $name = ucfirst($Nom_Complet{$login});
print $fh4 "$name ; $NUMBER{$login} ; $grpe ; \n";
}
#Report/Groupe
my $Groupe = qq/select ilicoUserLogin, Count(*) NB from ilico_log I where Date like ? GROUP BY I.ilicoUserLogin ORDER BY NB DESC /;
$sth = $dbh->prepare($Groupe) or die ("unable to prepare");
$sth->execute($Date) ;
while( #user = $sth -> fetchrow_array())
{
$user[0] =~ s/\s+/ /g;
my $login = lc($user[0]);
$LOGIN_W{my $grp}{$login} = $user[1];
}
foreach my $login ( keys %LOGIN_W) {
if (defined( $login ) and $login ne '')
{
$sum{$LOGIN_W{$login}} += $LOGIN_W{my $var}{$login} ;
}
}
for my $key (sort {$sum{$b} <=> $sum{$a}} keys %sum) {
if ($sum{$key})
{
my $KEYS = uc($key);
print $fh6 "$KEYS; $sum{$key}; \n";
}
}
close $fh1;
close $fh2;
close $fh3;
close $fh4;
close $fh5;
close $fh6;
my $msg = MIME::Lite->new (
From => 'maha.mastouri#st.com',
To => 'maha.mastouri#st.com',
# Cc => 'maha.mastouri#st.com',
Subject => "iLico Mertique $Month",
Type => 'text/plain' ,
Path => '/home/dev/text'
);
$msg->attach( Type => 'TEXT',
Path => '/home/dev/NBgenerated_Reports.csv',
Disposition => 'attachment',
Filename => 'NB_generated_Reports.csv'
);
$msg->attach( Type => 'TEXT',
Path => '/home/dev/Top_10_Features.csv',
Disposition => 'attachment',
Filename => 'Top_10_Features.csv'
);
$msg->attach( Type => 'TEXT',
Path => '/home/dev/Report_Scope.csv',
Disposition => 'attachment',
Filename => 'Report_Scope.csv'
);
$msg->attach( Type => 'TEXT',
Path => '/home/dev/Top_10_Users.csv',
Disposition => 'attachment',
Filename => 'Top_10_Users.csv'
);
$msg->attach( Type => 'TEXT',
Path => '/home/dev/Report_Groupe.csv',
Disposition => 'attachment',
Filename => 'Report_Groupe.csv'
);
$msg->send();
cron context is very different than a login shell. It has no env vars by default. It appears to me that your program depends on $ENV{USER} to build it's output (or input). Well, that env var is just going to be missing from cron. crontabs are executed by "cron" daemon and not as your login shell.
You can try to print the whole %ENV to somewhere like "/tmp/env.txt" just to see that it's basically an empty hash. It's the best if you can change the program not to depend on env var. You may also try to add them back right before the schedule line:
USER=dev
/3 * * * * /home/dev/metrique.pl &> /home/dev/output.txt
I must also notify you that after doing this, the env var USER becomes present for all the schedules below these 2 lines. Those env vars can also be inspected by ps e.
If an env var is required just to decide an input path, than it's as easy as getting the input path from #ARGV
It should run your .profile(or .bash_profile for bash) before executing the commands from cron.So, put it before your command in cron as shown. Similarly if there are any profile scripts which you run on login that is used in the perl script, those have to be included.
/3 * * * * . $HOME/.profile; /home/dev/metrique.pl &> /home/dev/output.txt
I solved the problem, crontab execute the script in the home "/home/httpldev/" (default), so I changed the execution path by following;
0 9 1 * * cd /home/httpldev/iLicoMetrics/ && /home/httpldev/iLicoMetrics/metrique.pl &> /dev/null .
Thank you a lot for your help.

Perl script for downloading a file not working

This is a test script I wrote to download a file from an URL.
The URL must be a direct link to the download file, and depending on the time provided, the program will count down and download at the specified time.
The problem is, it works for smaller file (~kb), but when I try for big files it freezes.
my $url = 'http://releases.ubuntu.com/14.04.2/ubuntu-14.04.2-desktop-amd64.iso';
my $file = '//strawberry//myscripts//ubuntu-14.04.2-desktop-amd64.iso';
my $starttime = '08.07.15 11:43:11';
my $nowtime = time; # time in sec since 1970
my $sTime = 0;
my $sleepSec = 0;
# parsing the input (start) time
if ( $starttime =~ /^\s*(\d{1,2})\.(\d{1,2})\.(\d{2})\s+(\d{1,2})\:(\d{1,2})\:(\d{1,2})/ ) {
# mktime(sec,min,hr,day,month,year)
# month (0..11); year = 0 => 1900 , year = 100 => 2000
$sTime = mktime( $6, $5, $4, $1, $2 - 1, 100 + $3 );
}
print "\nNow, the time is ---", ctime( $nowtime );
print "\nDownload will start at ---", ctime( $sTime );
$sleepSec = difftime( $sTime, $nowtime );
if ( $sleepSec > 0 ) {
print "I will sleep for $sleepSec seconds, and then download it. zzZ\n";
my $num = $sleepSec;
while ( $num-- ) {
sleep( 1 );
$| = 1;
print "$num\r";
}
my $status = getstore( $url, $file );
die "Error $status on $url" unless is_success( $status );
print "Your file has been downloaded successfully.\n";
}
else {
print "Shit I missed my starttime...\n";
}

Run a background process in perl, don't wait for it to finish

EDIT: found a solution here:
http://www.webmasterworld.com/forum13/4416.htm
Apparently it's way easier to do on Linux servers than Windows, google came through.
#Print out whatever you're going to print
print "Stuff in progress. Thanks."
# Close the I/O handles
close(STDIN);
close(STDOUT);
close(STDERR);
# run your other code here
I don't work in perl at all so the easiest solution is best for me. I'm just trying to figure out how to modify this program to make it do what I want.
Basically what this program is the broker for a UI. What it does is take a program name, print commands to a SAS program file including which SAS program to run to create output, then runs the SAS program, which then outputs the $pname.out file at the end, which is what is finally printed to the UI screen.
The latest SAS program created can take a long time, so I plan to to run the SAS program in the background as the child and have the SAS send an email when it's done.
In the foreground i.e. parent, I want to have the perl program return a screen with some basic info.
So my question basically is, how do I tell perl to run the child process in the background and not wait for it to be done?
I tried "&" on the end of the system ("$SASROOT $saschild") command, but it just prevented the program from running at all. If I use the command without "&", the program doesn't return anything to the browser screen until the child is done running.
Any help would be appreciated!
#!perl
use CGI ;
# YOUR MODIFICATIONS START HERE
$TEMPFILES = "c:\\temp"; # This is the directory SAS will write its temporary files
$PROGROOT = "c:\\Inetpub\\wwwroot\\Effectiveness"; # This is the directory that contains the SAS programs to run
$DATAROOT = "c:\\Inetpub\\wwwroot\\Effectiveness" ; # This is the directory that contains the SAS data sets to be analysed
$SASROOT = "D:\\SAS\\SASFoundation\\9.2\\sas.exe"; # This is the full path name of the SAS System
$CGIBIN = "\\" ; # This is the alias of cgi-bin directory
$HTTPURL ="http://10.240.7.172" ;
$WEBROOT = "c:\\Inetpub\\wwwroot\\Effectiveness" ; # This is the root directory of webserver
$SASCFG = "d:\\SAS\\SASFoundation\\9.2\\SASV9.CFG" ; # This is the path to SAS config file
# YOUR MODIFICATIONS END HERE
&get_request;
$PROGFILE = $rqpairs{'_program'};
if (!($PROGFILE =~ /^(\w[\w\.\-]+)$/))
{
&error("The hidden field <CODE>_program</CODE> (= \"$PROGFILE\") is invalid or missing.");
}
$SASPROG="$PROGROOT\\$PROGFILE.sas";
if (!-f $SASPROG)
{
&error("The program file \"$SASPROG\" does not exist.");
}
$pname = "p$$";
$cname = "c$$" ;
$repname = "r$$" ;
$random = int(rand("$$"));
$pname = "$pname$random" ;
$cname = "$cname$random" ;
$repname = "$repname$random" ;
open(OUTCON, "+>>$TEMPFILES\\$cname.sas") ;
print OUTCON "-set outfl \"$TEMPFILES\\$pname.out\" \n" ;
#print OUTCON "%include \"$TEMPFILES\\config.tpl\" \n";
print OUTCON "%include \"$SASCFG\" \n";
close(OUTCON) ;
open(OUTFI,"+>>$TEMPFILES\\$pname.sas");
print OUTFI "options set=cgibin \"$CGIBIN/broker.pl\" ; \n" ;
print OUTFI "options set=location \"$DATAROOT\" ; \n" ;
print OUTFI "options set=webroot \"$WEBROOT\" ; \n" ;
print OUTFI "options set=outfl \"$TEMPFILES\\$pname.out\" ; \n" ;
print OUTFI "options set=outrep \"$WEBROOT\\$repname.xls\" ; \n" ;
print OUTFI "options set=repline \"$HTTPURL\\broker.pl?_program=_result\" ; \n" ;
print OUTFI "options set=excel_file=\"$repname.xls\" ; \n" ;
print OUTFI "options mprint ; \n" ;
while ( ($name,$value) = each %rqpairs )
{
$value =~ s/([%()])/%$1/g ;
# $value =~ tr/ /\n/s ;
# $value =~ tr/,/,\n/s ;
# $in_string =~ tr/\+/ /s; # translate and squeeze multiple spaces
if ($name ne "var")
{
print OUTFI "%let $name = %nrstr($value);\n";
}
}
print OUTFI "%include \"$SASPROG\";\n";
close(OUTFI) ;
$sasoptions = " -nodms -sysin $TEMPFILES\\$pname.sas -log $TEMPFILES\\$pname.log -work $TEMPFILES -sasuser $TEMPFILES" ;
#THIS IS THE FORKING OF THE PROCESS - only fork for rfcost application
my $pid = fork();
if (defined $pid && $pid == 0){
#child
close STDIN; #close connections to webpage
close STDOUT; #close connections to webpage
$saschild = " -nodms -sysin $TEMPFILES\\TestOutput.sas -log $TEMPFILES\\TestOutput.log -work $TEMPFILES -sasuser $TEMPFILES" ;
system ("$SASROOT $saschild");
exit(0);
}
# sleep(120);
system ("$SASROOT $sasoptions");
#system ("$SASROOT -rsasuser -noterminal -sysparm -sysin $TEMPFILES\\$pname.sas -log $TEMPFILES\\$pname.log -config $TEMPFILES\\$cname.sas");
print "HTTP/1.0 200 OK\n";
print "Content-type: text/html\n\n";
&html_trailer;
#print "$sasoptions" ;
open (FILE, "$TEMPFILES\\$pname.out");
while (<FILE>){ print; }
close (FILE);
&html_trailer;
#unlink("$TEMPFILES/$pname.sas");
#unlink("$TEMPFILES/$pname.log");
#unlink("$TEMPFILES/$pname.lst");
#unlink("$TEMPFILES/$pname.out");
#unlink("$TEMPFILES/$cname.sas");
sub get_request
{
if ($ENV{'REQUEST_METHOD'} eq "POST") {
read(STDIN, $request, $ENV{'CONTENT_LENGTH'});
} elsif ($ENV{'REQUEST_METHOD'} eq "GET" ) {
$request = $ENV{'QUERY_STRING'};
}
%rqpairs = ();
#rqarray = &url_decode(split(/[&=]/, $request));
while ( $key = shift(#rqarray) )
{
$value = shift(#rqarray);
if ( $rqpairs{$key} ne "" )
{
$rqpairs{$key} .= "," . $value;
}
else
{
$rqpairs{$key} = $value;
}
}
}
sub url_decode
{
foreach (#_)
{
tr/+/ /;
s/%(..)/pack("c",hex($1))/ge;
}
#_;
}
sub html_header
{
local($title) = #_;
print "HTTP/1.0 200 OK\n";
print "Content-type: text/html\n\n";
print "<html><head>\n";
print "<title>$title</title>\n";
print "</head>\n<body>\n";
}
sub html_trailer
{
local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst)
= gmtime;
local($mname) = ("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul",
"Aug", "Sep", "Oct", "Nov", "Dec")[$mon];
local($dname) = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri",
"Sat")[$wday];
# print "<br><p>Date: $hour:$min:$sec on $dname $mday $mname $year</p> \n" ;
print "</body></html>\n";
}
sub error
{
local($msg) = #_;
&html_header("SAS CGI Process Error");
print "<H1>SAS CGI Process Error</H1>\n$msg\n";
&html_trailer;
exit 1;
}
Use exec (as quicoju suggested) to execute a command in background
See here for more details: http://perldoc.perl.org/functions/exec.html
exec PROGRAM LIST
The exec function executes a system command and never returns; use system instead of exec if you want it to return. It fails and returns false only if the command does not exist and it is executed directly instead of via your system's command shell (see below).
A very good answer you will find in this thread: What's the difference between Perl's backticks, system, and exec?
There are various CPAN modules which may make task easier, for example http://search.cpan.org/~bzajac/Proc-Background-1.10/lib/Proc/Background.pm
Having said that, I'd consider introducing some job queue, so your process puts task into the queue and separate process picks it up to handle, more manageable...

Serving Image with Perl prints wrong Content-Length (Gives net::ERR_CONTENT_LENGTH_MISMATCH in Chrome)

Activeperl 5.16 + Windows environment.
Windows machine:
Summary of my perl5 (revision 5 version 16 subversion 3) configuration:
Linux machine:
Summary of my perl5 (revision 5 version 14 subversion 2) configuration:
Doesn't occur on Linux based at all with the same code.
Here's my code that fetches a weather gif image, and does some magic (serving from cached directory for failover support in case internet dies or remote server does a radar update in the middle of a fetch, going offline)
sub get_map
{
my $whichImage = $_[0];
my $ua = LWP::UserAgent->new;
my $cache_file = $GLOB{'cache_mapA'}; # tempdata file path
my $cache_file_age = 100000; # this is used to determine if we have to get fresh data from the ems site will hold the tempdata file age in seconds
my $data = ''; # initializing empty data variable to enable later check for empty variable
my $cache_time = $GLOB{'cache_timeMap'}; # Max age of the temdata file in seconds
my $useCached = 0;
my $url = $GLOB{'mapAurl'};
if( $whichImage eq "B" )
{
$cache_file = $GLOB{'cache_mapB'};
$url = $GLOB{'mapBurl'};
}
if ( -s $cache_file ) # test existence of the tempdata file - if it has a size it exists
{
my $mtime = ( stat $cache_file )[9]; # get the Unix time of the last change (in seconds)
my $current_time = time; # get the current Unix time (in seconds)
$cache_file_age = $current_time - $mtime; # get the age of the tempdata fileim seconds!
}
if( $cache_file_age > $cache_time ) # check if we have to query the ems server
{
my $response = $ua->get($url);
if ($response->is_success) # checking if we were able to get the website
{
$data = $response->decoded_content( charset => 'none' );
open my $filehandle , '>' , $cache_file or die 'Horribly';
binmode $filehandle;
print $filehandle $data;
close $filehandle;
}
}
my $file = $cache_file;
my $length = -s $file;
print "Content-type: image/gif\n";
print "Content-length: $length \n\n";
binmode STDOUT;
open (FH,'<', $file) || die "Could not open $file: $!";
my $buffer = "";
while (read(FH, $buffer, 10240))
{
print $buffer;
}
close(FH);
}
cache_mapA points to tmp/map.A.gif and cache
Going to http://mywebserver.com/whatever.cgi?type=mapA gives a corrupted gif file that shows net::ERR_CONTENT_LENGTH_MISMATCH in Google Chrome's debugger.
Going to http://mywebserver.com/tmp/map.A.gif works fine in a browser.
Tried switching server software on my test box, Apache and LightTPD both show this behavior.
I'm out of ideas since this works perfectly fine on non Windows based machine.
It's possible there is an issue with this section but it looks fine to me:
print "Content-type: image/gif\n";
print "Content-length: $length \n\n";
binmode STDOUT;
open (FH,'<', $file) || die "Could not open $file: $!";
my $buffer = "";
while (read(FH, $buffer, 10240))
{
print $buffer;
}
close(FH);
Help!
You did binmode STDOUT but not binmode FH. Windows Perl opens files with :crlf enabled by default; Unix Perl does not.
The more modern technique would be open (FH,'<:raw', $file) instead of using a separate call to binmode.
If the image displays in other browsers, then the corruption for that particular image is probably minor enough that it doesn't prevent decoding.

Perl cron job stays running

I'm currently using a cron job to have a perl script that tells my arduino to cycle my aquaponics system and all is well, except the perl script doesn't die as intended.
Here is my cron job:
*/15 * * * * /home/dburke/scripts/hal/bin/main.pl cycle
And below is my perl script:
#!/usr/bin/perl -w
# Sample Perl script to transmit number
# to Arduino then listen for the Arduino
# to echo it back
use strict;
use Device::SerialPort;
use Switch;
use Time::HiRes qw ( alarm );
$|++;
# Set up the serial port
# 19200, 81N on the USB ftdi driver
my $device = '/dev/arduino0';
# Tomoc has to use a different tty for testing
#$device = '/dev/ttyS0';
my $port = new Device::SerialPort ($device)
or die('Unable to open connection to device');;
$port->databits(8);
$port->baudrate(19200);
$port->parity("none");
$port->stopbits(1);
my $lastChoice = ' ';
my $signalOut;
my $args = shift(#ARGV);
# Parent must wait for child to exit before exiting itself on CTRL+C
if ($args eq "cycle") {
open (LOG, '>>log.txt');
print LOG "Cycle started.\n";
my $stop = 0;
sleep(2);
$SIG{ALRM} = sub {
print "Expecting plant bed to be full; please check.\n";
$signalOut = $port->write('2'); # Signal to set pin 3 low
print "Sent cmd: 2\n";
$stop = 1;
};
$signalOut = $port->write('1'); # Signal to arduino to set pin 3 High
print "Sent cmd: 1\n";
print "Waiting for plant bed to fill...\n";
print LOG "Alarm is being set.\n";
alarm (420);
print LOG "Alarm is set.\n";
while ($stop == 0) {
print LOG "In while-sleep loop.\n";
sleep(2);
}
print LOG "The loop has been escaped.\n";
die "Done.";
print LOG "No one should ever see this.";
}
else {
my $pid = fork();
$SIG{'INT'} = sub {
waitpid($pid,0) if $pid != 0; exit(0);
};
# What child process should do
if($pid == 0) {
# Poll to see if any data is coming in
print "\nListening...\n\n";
while (1) {
my $incmsg = $port->lookfor(9);
# If we get data, then print it
if ($incmsg) {
print "\nFrom arduino: " . $incmsg . "\n\n";
}
}
}
# What parent process should do
else {
sleep(1);
my $choice = ' ';
print "Please pick an option you'd like to use:\n";
while(1) {
print " [1] Cycle [2] Relay OFF [3] Relay ON [4] Config [$lastChoice]: ";
chomp($choice = <STDIN>);
switch ($choice) {
case /1/ {
$SIG{ALRM} = sub {
print "Expecting plant bed to be full; please check.\n";
$signalOut = $port->write('2'); # Signal to set pin 3 low
print "Sent cmd: 2\n";
};
$signalOut = $port->write('1'); # Signal to arduino to set pin 3 High
print "Sent cmd: 1\n";
print "Waiting for plant bed to fill...\n";
alarm (420);
$lastChoice = $choice;
}
case /2/ {
$signalOut = $port->write('2'); # Signal to set pin 3 low
print "Sent cmd: 2";
$lastChoice = $choice;
}
case /3/ {
$signalOut = $port->write('1'); # Signal to arduino to set pin 3 High
print "Sent cmd: 1";
$lastChoice = $choice;
}
case /4/ {
print "There is no configuration available yet. Please stab the developer.";
}
else { print "Please select a valid option.\n\n";}
}
}
}
}
When I run ps -ef I find the following output:
dburke 15294 15293 0 14:30 ? 00:00:00 /bin/sh -c /home/dburke/scripts/hal/bin/main.pl cycle
dburke 15295 15294 0 14:30 ? 00:00:00 /usr/bin/perl -w /home/dburke/scripts/hal/bin/main.pl cycle
Shouldn't there only be one process? Is it forking even though it received the cycle argument and the fork is outside of the cycle argument's if block?
Any idea why it wouldn't die from the statement die "Done.";? It runs fine from the command line and interprets the 'cycle' argument fine. When it runs in cron it runs fine, however, the process never dies and while each process doesn't continue to cycle the system it does seem to be looping in some way due to the fact that it ups my system load very quickly.
If you'd like more information, just ask. Thanks guys!
It looks as thought the issue was that my script originally encapsulated the cycle block inside of the fork which for some reason, unknown to me, was leaving a process open (possibly the child?). Taking the cycle block out of the fork has corrected the issue. Now it runs at the specified time and correctly dies after the cycle is complete leaving my cpu load for something more useful. :)
Thank you everyone who commented on my question. You suggestions helped me work through the issue.