array of ints remains undef after multiple push() calls - arrays

I'm trying to save error codes by:
#global space
my #retCodes;
#main
sub BuildInit {
my $actionStr = "";
my $compStr = "";
my #component_dirs;
my #compToBeBuilt;
foreach my $comp (#compList) {
#component_dirs = GetDirs($comp); #populates #component_dirs
}
print "Printing Action List: #actionList\n";
#---------------------------------------
#---- Setup Worker Threads ----------
for ( 1 .. NUM_WORKERS ) {
async {
while ( defined( my $job = $q->dequeue() ) ) {
worker($job);
}
};
}
#-----------------------------------
#---- Enqueue The Work ----------
for my $action (#actionList) {
my $sem = Thread::Semaphore->new(0);
$q->enqueue( [ $_, $action, $sem ] ) for #component_dirs;
$sem->down( scalar #component_dirs );
print "\n------>> Waiting for prior actions to finish up... <<------\n";
}
# Nothing more to do - notify the Queue that we're not adding anything else
$q->end();
$_->join() for threads->list();
return 0;
}
#worker
sub worker {
my ($job) = #_;
my ( $component, $action, $sem ) = #$job;
Build( $component, $action );
$sem->up();
}
#builder method
sub Build {
my ( $comp, $action ) = #_;
my $cmd = "$MAKE $MAKE_INVOCATION_PATH/$comp ";
my $retCode = -1;
given ($action) {
when ("depend") { $cmd .= "$action >nul 2>&1" } #suppress output
when ("clean") { $cmd .= $action }
when ("build") { $cmd .= 'l1' }
when ("link") { $cmd .= '' } #add nothing; default is to link
default { die "Action: $action is unknown to me." }
}
print "\n\t\t*** Performing Action: \'$cmd\' on $comp ***" if $verbose;
if ( $action eq "link" ) {
# hack around potential race conditions -- will only be an issue during linking
my $tries = 1;
until ( $retCode == 0 or $tries == 0 ) {
last if ( $retCode = system($cmd) ) == 2; #compile error; stop trying
$tries--;
}
}
else {
$retCode = system($cmd);
}
push( #retCodes, ( $retCode >> 8 ) );
#testing
if ( $retCode != 0 ) {
print "\n\t\t*** ERROR IN $comp: $# !! ***\n";
print "\t\t*** Action: $cmd -->> Error Level: " . ( $retCode >> 8 ) . "\n";
#exit(-1);
}
return $retCode;
}
Error that gets displayed:
Use of uninitialized value $maxReturnCode in concatenation (.) or
string at C:\script.pl line 66, line 415.
I can see from the first line of output though, that I get things like: Return Code: 0 Return Code: 0 Return Code: 2 ..

The issue here is that the code isn't sharing the array between threads; so because of that, each thread is modifying it's local copy of the array, not the global array as expected. The fix for this problem is to share the variable, and lock it before accessing it during the thread processing:
my #retCodes;
share(#retCodes);
...
#during the thread sub
lock(#retCodes);
push(#retCodes, ($retCode>>8));

Here's a stubbed-out runnable version that you should be able to modify a bit to do what you need:
#!/usr/bin/perl
use strict;
use warnings;
use List::Util 'max';
use threads;
#global space
my #retCodes = ();
share(#retCodes);
sub builder {
my ($comp, $cmd) = ('builder', 'test');
for my $retCode (qw/0 0 256/) {
print "\n\t\tReturn Code: " . ($retCode >>8) . "\n";
lock(#retCodes);
push(#retCodes, ($retCode>>8));
}
}
#main
builder();
# other threads started...
# wait for threads to complete...
printf "Codes: %s\n", join(', ', #retCodes);
my $maxReturnCode = max(#retCodes);
print "Highest Error Code: $maxReturnCode\n"; #<-- crashes with error below
exit($maxReturnCode);

Related

Converting code using hash to array

I am charged with making a Perl module more efficient. It takes log entries which are currently uniquely identified by date and server name and inserts them into our mysql database for later processing.
I've posted the original file and my attempt below. My code doesn't insert into the database. I'm sure its a simple array handling problem but not sure.
Original file
package UlsaSpectrumAnalyser;
use strict;
use warnings;
use Data::Dumper;
use EnmServiceGroup;
use StatsDB;
use DBI;
use StatsTime;
sub new
{
my $klass = shift;
my $self = bless {}, $klass;
return $self;
}
sub init($$$$)
{
my ($self,$r_cliArgs,$r_incr,$dbh) = #_;
$self->{'site'} = $r_cliArgs->{'site'};
$self->{'siteId'} = $r_cliArgs->{'siteId'};
$self->{'date'} = $r_cliArgs->{'date'};
if ( exists $r_incr->{'UlsaSpectrumAnalyser'} )
{
$self->{'r_UlsaSpectrumAnalyser'} = $r_incr->{'UlsaSpectrumAnalyser'}->{'r_UlsaSpectrumAnalyser'};
}
else
{
$self->{'r_UlsaSpectrumAnalyser'} = {};
}
my #subscriptions = ();
$self->{'serverMap'} = {};
foreach my $service( "pmservice", "saservice" ) {
my $r_serverMap = enmGetServiceGroupInstances($self->{'site'}, $self->{'date'},$service);
while ( my ($server,$serverId) = each %{$r_serverMap} ) {
push ( #subscriptions, {'server' => $server, 'prog' => 'JBOSS'} );
$self->{'serverMap'}->{$server} = $serverId;
}
}
return \#subscriptions;
}
sub handle($$$$$$$)
{
my ($self,$timestamp,$host,$program,$severity,$message,$messageSize) = #_;
if ( $::DEBUG > 9 ) { print "UlsaSpectrumAnalyser::handle got message from $host $program : $message\n"; }
# Skip any warnings/errors
if ( $severity ne 'info' ) {
return;
}
my ($time)=$timestamp=~/(\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}).*/;
my ($epochtime) = getDateTimeInMilliSeconds($timestamp);
if ( $::DEBUG > 3 ) { print "UlsaSpectrumAnalyser::handle got message from $time $host $program : $message\n"; }
#Sample Log
#2017-09-08 14:55:36,028 INFO [com.X.Y.itpf.EVENT_LOGGER] (ajp-executor-threads - 18) [administrator, Spectrum Analyzer, DETAILED, #ULSA_COMPONENT_FFT, MeContext=lienb4003, Samples=65510; FileParsingTime(ms)=50; FastFourierTime(ms)=370; PostProcessingTime(ms)=3; #ChartScalingTime(ms)=1; TotalTime(ms)=424]
if( $message =~ /.*ULSA_COMPONENT_FFT,\s+(\S+),\s+Samples=(\d+);\s+FileParsingTime\S+=(\d+);\s+FastFourierTime\S+=(\d+);\s+PostProcessingTime\S+=(\d+);\s+ChartScalingTime\S+=(\d+);\s+TotalTime\S+=(\d+)]/ ) {
my $activity = $epochtime . '##' . $host; #TODO Handle array instead of hash. Working on separately
my $serverid = $self->{'serverMap'}->{$host};
$self->{'r_UlsaSpectrumAnalyser'}->{$activity} = {
'time' => $time,
'epochtime' => $epochtime,
'serverid' => $serverid,
'source' => $1,
'sample' => $2,
'file_parsing_time' => $3,
'fast_fourier_time' => $4,
'post_processing_time' => $5,
'chart_scaling_time' => $6,
'total_time' => $7};
}
}
sub handleExceeded($$$)
{
my ($self, $host, $program) = #_;
}
sub done($$$)
{
my ($self,$dbh,$r_incr) = #_;
my $tmpDir = '/data/tmp';
my $date=$self->{'date'};
if (exists $ENV{'TMP_DIR'})
{
$tmpDir = $ENV{'TMP_DIR'};
}
my $bcpFileUlsaAnalyserLogs = "$tmpDir/ulsa_spectrum_analyser_logs.bcp";
open (BCP, "> $bcpFileUlsaAnalyserLogs") or die "Failed to open $bcpFileUlsaAnalyserLogs";
foreach my $activity (sort keys %{$self->{'r_UlsaSpectrumAnalyser'}}) {
print BCP $self->{'siteId'} . "\t" .
$self->{'r_UlsaSpectrumAnalyser'}->{$activity}->{'serverid'} . "\t" .
$self->{'r_UlsaSpectrumAnalyser'}->{$activity}->{'time'} . "\t" .
$self->{'r_UlsaSpiUectrumAnalyser'}->{$activity}->{'epochtime'} . "\t" .
$self->{'r_UlsaSpectrumAnalyser'}->{$activity}->{'source'} . "\t" .
$self->{'r_UlsaSpectrumAnalyser'}->{$activity}->{'sample'} . "\t" .
$self->{'r_UlsaSpectrumAnalyser'}->{$activity}->{'file_parsing_time'} . "\t" .
$self->{'r_UlsaSpectrumAnalyser'}->{$activity}->{'fast_fourier_time'} . "\t" .
$self->{'r_UlsaSpectrumAnalyser'}->{$activity}->{'post_processing_time'} . "\t" .
$self->{'r_UlsaSpectrumAnalyser'}->{$activity}->{'chart_scaling_time'} . "\t" .
$self->{'r_UlsaSpectrumAnalyser'}->{$activity}->{'total_time'} . "\n";
}
close BCP;
dbDo( $dbh, "DELETE FROM enm_ulsa_spectrum_analyser_logs WHERE siteid = $self->{'siteId'} AND time BETWEEN '$date 00:00:00' AND '$date 23:59:59'" )
or die "Failed to delete from enm_ulsa_spectrum_analyser_logs" . $dbh->errstr;
dbDo( $dbh, "LOAD DATA INFILE '$bcpFileUlsaAnalyserLogs' INTO TABLE enm_ulsa_spectrum_analyser_logs" )
or die "Failed to load new data from '$bcpFileUlsaAnalyserLogs' file to 'enm_ulsa_spectrum_analyser_logs' table" . $dbh->errstr;
unlink($bcpFileUlsaAnalyserLogs);
$r_incr->{'UlsaSpectrumAnalyser'} = {
'r_UlsaSpectrumAnalyser' => $self->{'r_UlsaSpectrumAnalyser'}
};
}
1;
My attempt
package UlsaSpectrumAnalyser;
use strict;
use warnings;
use Data::Dumper;
use StatsDB;
use DBI;
use StatsTime;
sub new
{
my $klass = shift;
my $self = bless {}, $klass;
return $self;
}
sub init($$$$)
{
my ($self,$r_cliArgs,$r_incr,$dbh) = #_;
$self->{'site'} = $r_cliArgs->{'site'};
$self->{'siteId'} = $r_cliArgs->{'siteId'};
$self->{'date'} = $r_cliArgs->{'date'};
$self->{'r_instrDataEvent'}->{'ulsaStats'} = [];
my #subscriptions = ();
$self->{'serverMap'} = {};
foreach my $service( "pmservice", "saservice" ) {
my $r_serverMap = enmGetServiceGroupInstances($self->{'site'}, $self->{'date'},$service);
while ( my ($server,$serverId) = each %{$r_serverMap} ) {
push ( #subscriptions, {'server' => $server, 'prog' => 'JBOSS'} );
$self->{'serverMap'}->{$server} = $serverId;
}
}
return \#subscriptions;
}
sub handle($$$$$$$)
{
my ($self,$timestamp,$host,$program,$severity,$message,$messageSize) = #_;
if ( $::DEBUG > 9 ) { print "UlsaSpectrumAnalyser::handle got message from $host $program : $message\n"; }
# Skip any warnings/errors
if ( $severity ne 'info' ) {
return;
}
my ($time)=$timestamp=~/(\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}).*/;
my ($epochtime) = getDateTimeInMilliSeconds($timestamp);
if ( $::DEBUG > 3 ) { print "UlsaSpectrumAnalyser::handle got message from $time $host $program : $message\n"; }
#Sample Log
#2017-09-08 14:55:36,028 INFO [com.X.y.itpf.EVENT_LOGGER] (ajp-executor-threads - 18) [administrator, Spectrum Analyzer, DETAILED, #ULSA_COMPONENT_FFT, MeContext=lienb4003, Samples=65510; FileParsingTime(ms)=50; FastFourierTime(ms)=370; PostProcessingTime(ms)=3; #ChartScalingTime(ms)=1; TotalTime(ms)=424]
if( $message =~ /.*ULSA_COMPONENT_FFT,\s+(\S+),\s+Samples=(\d+);\s+FileParsingTime\S+=(\d+);\s+FastFourierTime\S+=(\d+);\s+PostProcessingTime\S+=(\d+);\s+ChartScalingTime\S+=(\d+);\s+TotalTime\S+=(\d+)]/ ) {
my $serverid = $self->{'r_instrDataEvent'}->{'serverid'};
my %event = (
'time' => $time,
'epochtime' => $epochtime,
'serverid' => $serverid,
'source' => $1,
'sample' => $2,
'file_parsing_time' => $3,
'fast_fourier_time' => $4,
'post_processing_time' => $5,
'chart_scaling_time' => $6,
'total_time' => $7
);
push #{$self->{'r_instrDataEvent'}->{'ulsaStats'}}, \%event;
}
}
sub handleExceeded($$$)
{
my ($self, $host, $program) = #_;
}
sub done($$$)
{
my ($self,$dbh,$r_incr) = #_;
my $bcpFileUlsaAnalyserLogs = getBcpFilename("enm_ulsa_spectrum_analyser_logs ");
open (BCP, "> $bcpFileUlsaAnalyserLogs") or die "Failed to open $bcpFileUlsaAnalyserLogs";
foreach my $activity (#{$self->{'r_instrDataEvent'}->{'ulsaStats'}}) {
print BCP $self->{'siteId'} . "\t" .
$activity->{'serverid'} . "\t" .
$activity->{'time'} . "\t" .
$activity->{'epochtime'} . "\t" .
$activity->{'source'} . "\t" .
$activity->{'sample'} . "\t" .
$activity->{'file_parsing_time'} . "\t" .
$activity->{'fast_fourier_time'} . "\t" .
$activity->{'post_processing_time'} . "\t" .
$activity->{'chart_scaling_time'} . "\t" .
$activity->{'total_time'} . "\n";
}
close BCP;
dbDo( $dbh, sprintf("DELETE FROM enm_ulsa_spectrum_analyser_logs WHERE siteid = %d AND time BETWEEN '%s' AND '%s'",
$self->{'siteId'}, $self->{'r_instrDataEvent'}->{'ulsaStats'}->[0]->{'epochtime'},$self->{'r_instrDataEvent'}->{'ulsaStats'}->[$#{$self->{'r_instrDataEvent'}->{'ulsaStats'}}]->{'epochtime'}))
or die "Failed to delete from enm_ulsa_spectrum_analyser_logs" . $dbh->errstr;#'
dbDo( $dbh, "LOAD DATA INFILE '$bcpFileUlsaAnalyserLogs' INTO TABLE enm_ulsa_spectrum_analyser_logs" )
or die "Failed to load new data from '$bcpFileUlsaAnalyserLogs' file to 'enm_ulsa_spectrum_analyser_logs' table" . $dbh->errstr;
}
1;
I would say that the problem is your
my $bcpFileUlsaAnalyserLogs = getBcpFilename( "enm_ulsa_spectrum_analyser_logs " )
I doubt if the file name really has a space at the end!
I'm surprised that your dbDo or at least your
or die "Failed to load new data ... "
didn't catch this and report it. I don't like wrapping DBI code inside subroutines, especially when I can't see those subroutines.
Note also that you should be using placeholders
dbDo( $dbh, sprintf("DELETE FROM enm_ulsa_spectrum_analyser_logs WHERE siteid = %d AND time BETWEEN '%s' AND '%s'",
$self->{'siteId'}, $self->{'r_instrDataEvent'}->{'ulsaStats'}->[0]->{'epochtime'},$self->{'r_instrDataEvent'}->{'ulsaStats'}->[$#{$self->{'r_instrDataEvent'}->{'ulsaStats'}}]->{'epochtime'}))
or die "Failed to delete from enm_ulsa_spectrum_analyser_logs" . $dbh->errstr;#'
would be much better as
my $sth = $dbh->prepare(<<END_SQL);
DELETE FROM enm_ulsa_spectrum_analyser_logs
WHERE siteid = ? AND time BETWEEN ? AND ?
END_SQL
my $ulsa_stats = $self->{r_instrDataEvent}{ulsaStats};
$sth->execute(
$self->{siteId},
$ulsa_stats->[0]{epochtime},
$ulsa_stats->[-1]{epochtime}
) or die "Failed to delete from enm_ulsa_spectrum_analyser_logs: " . $dbh->errstr;

Passing an array into Perl subroutine

I have a subroutine that should take an array as input, make it into a CSV, and POST it to a URL. Here's what I've got so far:
An example array:
[ 2823383062, 1411691539, 1411691541, 'outgoing',
'SIP/fr', 'user#2000', '2000', 'SIP/2000-000000a2',
undef, '6125551234', 'SIP/fr-000000a3', undef,
undef, 8, 'Answered', 2,
1, 'nada'
];
The subroutine:
sub send_http {
my #http = #_;
my $h = LWP::UserAgent->new;
$h->timeout(15);
$h->agent(undef);
my $testkey = "1234";
my $apikey = "4567";
my $posting;
foreach my $v ( \#http ) {
if ( defined $v ) {
$posting = join( ',', $posting, $v );
} else {
$posting = join( ',', $posting, "" );
}
}
my $api_response = $h->post( 'http://url.com/v1/post.cfm',
[ key => $testkey, method => 'pushCalls', rawdata => $posting ] );
}
Forgive all the horrible things I've done; this is my first time using Perl and I'm still learning all sorts of stuff. My issue is that I can't seem to get the values from the array I pass into it past the first array variable declaration (#http). I've read something about getting a reference of the array, but am not sure where/how to do so. Any help is appreciated.
Edit:
Here's the entire script. It does (or should) two things; send some string of data to a TCP socket, and some other data gets POST'ed to a URL. Thanks everyone for your help.
#!/usr/bin/perl
use EV;
use Asterisk::AMI;
use Net::Telnet;
use HTTP::Request::Common;
use LWP::UserAgent;
use strict;
use warnings;
use Data::Dumper;
my %call;
my $t = new Net::Telnet (
Timeout => 10,
Port => '1234',
Telnetmode => 1
);
my $astman = Asterisk::AMI->new(PeerAddr => '127.0.0.1',
PeerPort => '5038',
Username => 'secret',
Secret => 'user',
Events => 'on',
Handlers => {
# default => \&eventhandler,
Dial => \&dialcheck,
Bridge => \&bridgecheck,
Newchannel => \&newchannel,
Newexten => \&newexten,
Hangup => \&hangup,
Newstate => \&outring
}
);
die "Unable to connect to asterisk" unless ($astman);
sub send_pos {
my ($pos_string,$telnet) = #_;
$telnet->open('127.0.0.1');
printf $t $pos_string;
$telnet->close()
}
sub send_http {
my $http = shift; ##_;
my $h = LWP::UserAgent->new;
$h->timeout(15);
$h->agent(undef);
my $testkey = "1234";
my $apikey = "5678";
my $posting;
foreach my $v ( #http ) {
if ( defined $v ) {
$posting = join(',', $posting,$v);
} else {
$posting = join(',', $posting,"");
}
}
my $api_response = $h->post( 'http://url.com/v1/post.cfm',[key => $testkey,method => 'pushCalls',rawdata => $posting]);
}
sub eventhandler {
# Default event handler, not used
my ($ami, $event) = #_;
print 'Got Event: ',$event->{'Event'},"\r\n";
}
sub newchannel {
my ($ami, $event) = #_;
my $unique_id = $event->{'Uniqueid'};
if ( not exists $call{$unique_id} ) {
my $this_call = $call{$unique_id};
if ( (not defined $this_call->{'gravityfree'}[3]) ) {# || ($this_call->{'gravityfree'}[3] !~ /incoming|outgoing/) ) {
if ( $event->{'Context'} =~ /from-trunk/ ) {
# Call is inbound
$this_call->{'caller_name'} = $event->{'CallerIDName'};
$this_call->{'caller_number'} = substr $event->{'CallerIDNum'}, -10;
$this_call->{'dnis'} = substr $event->{'Exten'}, -10;
$this_call->{'status'} = "remote";
$this_call->{'holdstart'} = time();
# Data required for Gravity Free
$this_call->{'gravityfree'}[0] = int($event->{'Uniqueid'})+int(time());
$this_call->{'gravityfree'}[3] = "incoming";
$this_call->{'gravityfree'}[5] = $event->{'CallerIDName'};
$this_call->{'gravityfree'}[6] = substr $event->{'CallerIDNum'}, -10;
$this_call->{'gravityfree'}[7] = $event->{'Channel'};
$this_call->{'gravityfree'}[11] = substr $event->{'Exten'}, -10;
# Can't remember why this is here:
$call{$unique_id} = $this_call;
} elsif ( $event->{'Context'} =~ /from-internal/ ) {
# Call is outbound
# Separate from calls to stations
if( length($event->{'CallerIDNum'}) < length($event->{'Exten'}) ) {
$this_call->{'status'} = "remote";
# Data required for Gravity Free
$this_call->{'gravityfree'}[0] = int($event->{'Uniqueid'})+int(time());
$this_call->{'gravityfree'}[9] = substr $event->{'Exten'}, -10;
$this_call->{'gravityfree'}[3] = "outgoing";
$this_call->{'gravityfree'}[6] = $event->{'CallerIDNum'};
$this_call->{'gravityfree'}[5] = $event->{'CallerIDName'};
$call{$unique_id} = $this_call;
} elsif ( length($event->{'CallerIDNum'}) == length($event->{'Exten'}) ) {
# Call is station to station
$this_call->{'status'} = "station-to-station";
}
}
}
}
}
sub newexten {
my ($ami, $event) = #_;
my $unique_id = $event->{'Uniqueid'};
my $this_call = $call{$unique_id};
# Handles inbound calls only
if ( defined $this_call->{'status'} && $this_call->{'status'} ne "station-to-station" ) {
# Call is not station to station
# Check if the DID has been defined
if ( not defined $this_call->{'gravityfree'}[13] ) {
if ( $event->{'Context'} eq 'ext-group' ) {
# Data required for Gravity Free
$this_call->{'gravityfree'}[13] = $event->{'Extension'};
}
}
}
}
sub dialcheck {
my ($ami, $event) = #_;
my $unique_id = $event->{UniqueID};
if ( exists $call{$unique_id} ) {
my $this_call = $call{$unique_id};
if ( defined $this_call->{'status'} && $this_call->{'status'} ne "station-to-station" ) {
# Call is not station to station
if ( $event->{'SubEvent'} eq 'Begin' && $this_call->{'gravityfree'}[3] =~ "incoming" ) {
# Call is inbound
$this_call->{'system_extension'} = $event->{'Dialstring'};
$this_call->{'dest_uniqueid'} = $event->{'DestUniqueID'};
# Data required for Gravity Free
$this_call->{'gravityfree'}[4] = $1 if $event->{'Channel'} =~ /(.+(?=\-\w+)).*/;
# Telnet data to Prodigy
my $sending = "R|$this_call->{'caller_name'}|$this_call->{'caller_number'}|$this_call->{'system_extension'}||$this_call->{'dnis'}|";
send_pos($sending,$t);
$this_call->{'status'} = "ringing";
} elsif ( $event->{SubEvent} eq 'Begin' && $this_call->{'gravityfree'}[3] =~ "outgoing" ) {
# Call is outbound
# Data required for Gravity Free
$this_call->{'gravityfree'}[4] = $1 if $event->{'Destination'} =~ /(.+(?=\-\w+)).*/;
$this_call->{'gravityfree'}[10] = $event->{'Destination'};
$this_call->{'gravityfree'}[7] = $event->{'Channel'};
}
}
}
}
sub outring {
my ($ami, $event) = #_;
my $unique_id = $event->{'Uniqueid'};
my $this_call = $call{$unique_id};
if ( defined $this_call->{'status'} && $this_call->{'status'} ne "station-to-station" ) {
# Call is not station to station
if ( not defined $this_call->{'holdstart'} && $this_call->{'gravityfree'}[3] eq "outgoing" ) {
# Call is outbound
$this_call->{'holdstart'} = time();
}
}
}
sub bridgecheck {
my ($ami, $event) = #_;
my $unique_id = $event->{'Uniqueid1'};
my $this_call = $call{$unique_id};
if ( defined $this_call->{'status'} && $this_call->{'status'} ne "station-to-station" ) {
# Call is not station to station
if ( $event->{'Bridgestate'} eq "Link" && length($event->{'CallerID2'}) <= 4 ) {
# Call is inbound
$this_call->{'dest_uniqueid'} = $event->{Uniqueid2};
# Data required for Gravity Free
$this_call->{'gravityfree'}[1] = time();
$this_call->{'gravityfree'}[10] = $event->{Channel2};
my $sending = "A|$this_call->{caller_name}|$this_call->{caller_number}|$event->{CallerID2}||$this_call->{dnis}|";
send_pos($sending,$t);
$this_call->{'status'} = "answered";
} elsif ( $event->{'Bridgestate'} eq "Link" && length($event->{'CallerID2'}) >= 4 ) {
# Call is outbound
$this_call->{'gravityfree'}[1] = time();
$this_call->{'gravityfree'}[13] = $this_call->{'gravityfree'}[1]-$this_call->{holdstart};
}
}
}
sub hangup {
my ($ami, $event) = #_;
my $unique_id = $event->{'Uniqueid'};
my $this_call = $call{$unique_id};
if ( defined $this_call->{'status'} && not defined $this_call->{'gravityfree'}[16] && $this_call->{'status'} ne "station-to-station" ) {
# Call is not station to station
if ( $event->{'Cause-txt'} eq "Normal Clearing" ) {
# Call was hungup normally
$this_call->{'dest_uniqueid'} = $event->{Uniqueid};
# Call has ended, get date/time
$this_call->{'gravityfree'}[2] = time();
# Mark call 'completed'
$this_call->{'gravityfree'}[16] = 1;
# Set notes to nothing
$this_call->{'gravityfree'}[17] = 'nada';
if ( defined $this_call->{'gravityfree'}[3] && $this_call->{'gravityfree'}[3] eq "incoming") {
# Call was inbound
if ( defined $this_call->{'gravityfree'}[1] ) {
# Call was answered
$this_call->{'gravityfree'}[13] = $this_call->{'gravityfree'}[1]-$this_call->{holdstart};
$this_call->{'gravityfree'}[14] = "Answered";
$this_call->{'gravityfree'}[15] = $this_call->{'gravityfree'}[2]-$this_call->{'gravityfree'}[1];
$this_call->{'gravityfree'}[8] = $event->{'ConnectedLineName'};
$this_call->{'gravityfree'}[9] = substr $event->{'ConnectedLineNum'}, -10;
# POST data to gravity free
send_http(\$this_call->{'gravityfree'});
} else {
# Call was abandoned
$this_call->{'gravityfree'}[14] = "Abandoned";
$this_call->{'gravityfree'}[13] = $this_call->{'gravityfree'}[2]-$this_call->{holdstart};
$this_call->{'gravityfree'}[15] = 0;
# POST data to gravity free
send_http(\$this_call->{'gravityfree'});
}
} elsif ( defined $this_call->{'gravityfree'}[3] && $this_call->{'gravityfree'}[3] eq "outgoing" ) {
# Call is outbound
if ( defined $this_call->{'gravityfree'}[1] ) {
# Call was bridged at some point
$this_call->{'gravityfree'}[15] = $this_call->{'gravityfree'}[2]-$this_call->{'gravityfree'}[1];
$this_call->{'gravityfree'}[14] = "Answered";
# POST data to gravity free
send_http(\$this_call->{'gravityfree'});
} else {
# Call was hung up before anyone answered
$this_call->{'gravityfree'}[15] = 0;
$this_call->{'gravityfree'}[14] = "Abandoned";
$this_call->{'gravityfree'}[13] = $this_call->{'gravityfree'}[2]-$this_call->{holdstart};
# POST data to gravity free
send_http(\$this_call->{'gravityfree'});
}
}
}
}
}
EV::loop
First question, where are you getting the array you're passing into the subroutine?
I ask because your example array is actually an array reference.
That is:
#array = (1, 2, 3); # This is an array
$ref = [1, 2, 3]; # This is an array reference
If you want to pass an array reference to your subroutine, change the beginning to:
sub send_http {
my $http = shift;
Next, let us consider how to iterate over the elements of an array. This is the proper way to do so:
foreach my $element ( #array ) {
# do stuff ...
}
When you do \# on an array, you are actually creating a reference to the array. Thus, if you truly are passing an array to your subroutine, you should change your loop to the following:
foreach my $v ( #http ) {
However, if you decide to pass your array as a reference, you can dereference the pointer and iterate over its elements like this:
foreach my $v ( #$http ) {
Hope this helps!
EDIT: For the newly uploaded code...
You're very close but we have a couple of small issues:
$this_call->{'gravityfree'} is actually already an array reference, I'm not certain why it's allowing you to address the array elements with $this_call->{'gravityfree'}[INDEX], so perhaps someone more knowledgeable than me can enlighten us all. I will note that the correct way to deference an array is the following:
\#{$this_call->{'gravityfree'}}
Regardless, you can simply pass the reference to your subroutine, no need to create a reference. That is:
send_http($this_call->{'gravityfree'});
Now, inside of your subroutine, you have an array reference. You are correctly reading the subroutine argument, but you need to dereference the reference in your foreach loop. Like so:
foreach my $v ( #$http ) {
# ... loop body
}
Does this make sense? Please let me know if anything is unclear (or not working!)
I'm not entirely sure what you're trying to do but everything depends on how you pass the array to your subroutine. You have two choices, either pass it as an array:
send_http(#array)
or as a reference to an array:
send_http(\#array)
As others have noted, your array is already a reference since you're defining it in square brackets [ ].
Which one you want will depend on what exactly you're doing but the syntax is different. To pass an array and iterate through it:
sub send_http {
my #http = #_;
foreach my $v (#http) {
print "v is $v\n";
}
}
my #aa=("cc","dd");
send_http(#aa);
To pass a reference and iterate through the array it points to:
sub send_http {
## Remove the first value from the #_ array.
my $http = shift #_;
## Dereference it to an array. You could also use #{$http}
foreach my $v (#$http) {
print "v is $v\n";
}
}
my #aa=("cc","dd");
send_http(\#aa);
The main difference is that when you use send_http(\#aa); what you're passing is not an array so you can't treat it as one. It is instead a reference to an array. Something like
send_http(ARRAY(0x1d34030));
So, the contents of #_ are just a single reference, ARRAY(0x1d34030). To treat it as an array, you need to dereference it to get to what it points to.
So, into your send_http, the argument you received is array_ref which is scalar variable, so when you used it you need to dereference to the right type.
NB: square bracket is array_reference
So, please change as below:
my $http = shift;
And please use that as :
foreach my $v ( #$http ) {
Example:
my $array_ref = [1,2,3];
print "Reference: ", $array_ref,"\n";
print "Array: ", #$array_ref,"\n";
Output:
Reference: ARRAY(0x7f8e1c004ee8)
Array: 123

unable to itherate through the array perl

I have this perl script:
my %perMpPerMercHash;
foreach my $sheet () { #proper ranges specified
foreach my $row ( ) { #proper ranges specified
#required variables declared.
push(#{$perMpPerMercHash{join("-", $mercId, $mpId)}}, $mSku);
}
}
#Finally 'perMpPerMercHash' will be a hash of array`
foreach my $perMpPerMerc ( keys %perMpPerMercHash ) {
&genFile($perMpPerMerc, $perMpPerMercHash{$perMpPerMerc});
}
sub genFile {
my ( $outFileName, #skuArr ) = #_;
my $output = new IO::File(">$outFileName");
my $writer = new XML::Writer( OUTPUT => $output, DATA_MODE => 1, DATA_INDENT => 2);
#mpId is generated.
&prepareMessage($writer, $mpId, #skuArr);
}
sub prepareMessage {
my ( $writer, $mpId, #skuArr ) = #_;
my $count = 1;
print Dumper \#skuArr; #Printing correctly, 8-10 values.
foreach my $sku ( #skuArr ) { #not iterating.
print "loop run" , $sku, "\n"; #printed only once.
}
}
Can somebody please help why this is happening. I am new to perl and could not understand this anomaly.
EDIT:
output of Dumper:
$VAR1 = [
'A',
'B',
'C',
];
When you do
&genFile($perMpPerMerc, $perMpPerMercHash{$perMpPerMerc});
You're passing a reference to an array.
So in
sub genFile {
my ( $outFileName, #skuArr ) = #_;
You have to do :
sub genFile {
my ( $outFileName, $skuArr ) = #_;
and then use #$skuArr.
Have a look at references
The modified genFile sub will be:
sub genFile {
my ( $outFileName, $skuArr ) = #_;
my $output = new IO::File(">$outFileName");
my $writer = new XML::Writer( OUTPUT => $output, DATA_MODE => 1, DATA_INDENT => 2);
#mpId is generated.
&prepareMessage($writer, $mpId, #$skuArr);
}
And the other sub don't need to be modified.
Or you can pass always skuArr by reference:
&genFile($perMpPerMerc, $perMpPerMercHash{$perMpPerMerc});
...
sub genFile {
my ( $outFileName, $skuArr ) = #_;
...
&prepareMessage($writer, $mpId, $skuArr);
}
sub prepareMessage {
my ( $writer, $mpId, $skuArr ) = #_;
my $count = 1;
print Dumper $skuArr;
foreach my $sku ( #$skuArr ) {
print "loop run" , $sku, "\n";
}
}

Tool for discovering library dependencies based on missing symbols

I'm working on a 20 year old project with some ... interesting problems, among them: there's some shared objects with circular dependencies.
I'm attempting to map out the relationships between all the libraries, but it would be rather helpful if there's an existing tool capable of searching a list of libraries to see what can satisfy the missing dependencies.
For reference, they got around the problem by doing something like the following:
# True list of dependencies:
A: B
B: A
C: A
# Dependencies used in practice:
A:
B: A
C: A B
I haven't tested the following code, since I've just attempted to re-write this from memory, but the one I wrote to solve this earlier (it looks roughly like this one) works fine:
#!/usr/bin/env perl
using IPC::Open3;
my $queryFile = $ARGV[0];
shift;
my %missingSymbols = getSymbols( "nm -Aau", $queryFile );
my %symtbl;
foreach $lib ( #ARGV ) {
my %temp = getSymbols( "nm -Aa --defined-only", $lib );
foreach $key ( keys( %temp ) ) {
$symtbl{$key} = (defined($symtbl{$key}) ? "${symtbl{$key}} " : "")
. $temp{$key};
}
}
my %dependencies;
foreach $symbol ( keys( %missingSymbols ) ) {
if( defined( $symtbl{$symbol} ) ) {
foreach $lib ( split( / +/, $symtbl{$symbol} ) ) {
if( !defined( $dependencies{$lib} ) ) {
$dependencies{$lib} = 1;
}
}
}
}
if( scalar( keys( %dependencies ) ) > 0 ) {
print( "$queryFile depends on one or more of the following libs:\n\n" );
print join( "\n", sort( keys( %dependencies ) ) ) . "\n\n";
} else {
print( "Unable to resolve dependencies for $queryFile.\n\n" );
}
# Done.
sub getSymbols {
my $cmd = shift;
my $fname = shift;
checkFileType( $fname );
open3( IN, OUT, ERR, "$cmd $fname" );
my %symhash;
close( IN );
# If you leave ERR open and nm prints to STDERR, reads from
# OUT can block. You could make reads from both handles be
# non-blocking so you could examine STDERR if needed, but I
# don't need to.
close( ERR );
while( <OUT> ) {
chomp;
if( m/^(?:[^:]*:)+[a-zA-Z0-9]*\s*[a-zA-Z] ([^\s]+)$/ ) {
my $temp = defined( $symhash{$1} ) ? "${symhash{$1}} " : "";
$symhash{$1} = $temp . $fname;
}
}
close( OUT );
return %symhash;
}
sub checkFileType {
my $fname = shift;
die "$fname does not exist\n" if( ! -e $fname );
die "Not an ELF or archive file\n" if( `file $fname` !~ m/ELF| ar archive/ );
}

Why do I get "Global symbol '$href_array' requires specific package name" in Perl?

I can't seem to get these arrays to work. I'm getting errors along the following lines:
Global symbol '$href_array' requires specific package name
What does this mean? Here's part of my code:
sub scrape {
my ( $self, $DBhost, $DBuser, $DBpass, $DBname ) = #_;
my ($dbh, $query, $result, $array);
my $DNS = "dbi:mysql:$DBname:$DBhost:3306";
$dbh = DBI->connect($DNS, $DBuser, $DBpass ) or die $DBI::errstr;
if( defined( $self->{_process_image} ) && ( -e 'href_w_' . $self->{_process_image} . ".txt" ) ) {
open ERROR_W, "error_w_" . $self->{_process_image} . ".txt";
open M_HREF_W, "m_href_w_" . $self->{_process_image} . ".txt";
open HREF_W, "href_w_" . $self->{_process_image} . ".txt";
my #m_error_array = ( split( '|||', <ERROR_W> ) );
my #m_href_array = ( split( '|||', <M_HREF_W> ) );
my #href_array = ( split( '|||', <HREF_W> ) );
close ( ERROR_W );
close ( M_HREF_W );
close ( HREF_W );
}else{
my #m_error_array;
my #m_href_array;
my #href_array = ( $self->{_url} );
}
my $z = 0;
while( $href_array ){
if( defined( $self->{_x_more} ) && $z == $self->{_x_more} ) {
break;
}
if( defined( $self->{_process_image} ) ) {
$self->write( 'm_href_w', #m_href_array );
$self->write( 'href_w', #href_array );
$self->write( 'error_w', #m_error_array );
}
$self->{_link_count} = scalar #m_href_array;
}
}
FIXED:
#!/usr/bin/perl
use strict;
use URI;
use File::Basename;
use DBI;
package Crawler;
sub new {
my $class = shift;
my $self = {
_url => shift,
_max_link => 0,
_local => 1
};
bless $self, $class;
return $self;
}
sub process_image {
my ($self, $process_image) = #_;
$self->{_process_image} = $process_image;
}
sub local {
my ($self, $local) = #_;
$self->{_local} = $local;
}
sub max_link {
my ($self, $max_link) = #_;
$self->{_max_link} = $max_link;
}
sub x_more {
my ($self, $x_more) = #_;
$self->{_x_more} = $x_more;
}
sub resolve_href {
my ($base, $href) = #_;
my $uri = URI->new($href);
return $uri->rel($base);
}
sub write {
my ( $self, $ref, $data ) = #_;
open FILE, '>>' . $ref . '_' . $self->{_process_image} . '.txt';
print FILE join( '|||', $data );
close( FILE );
}
sub scrape {
my #m_error_array;
my #m_href_array;
my #href_array;
my ( $self, $DBhost, $DBuser, $DBpass, $DBname ) = #_;
my ($dbh, $query, $result, $array);
my $DNS = "dbi:mysql:$DBname:$DBhost:3306";
$dbh = DBI->connect($DNS, $DBuser, $DBpass ) or die $DBI::errstr;
if( defined( $self->{_process_image} ) && ( -e 'href_w_' . $self->{_process_image} . ".txt" ) ) {
open ERROR_W, "error_w_" . $self->{_process_image} . ".txt";
open M_HREF_W, "m_href_w_" . $self->{_process_image} . ".txt";
open HREF_W, "href_w_" . $self->{_process_image} . ".txt";
my #m_error_array = ( split( '|||', <ERROR_W> ) );
my #m_href_array = ( split( '|||', <M_HREF_W> ) );
my #href_array = ( split( '|||', <HREF_W> ) );
close ( ERROR_W );
close ( M_HREF_W );
close ( HREF_W );
}else{
#href_array = ( $self->{_url} );
}
my $z = 0;
while( #href_array ){
if( defined( $self->{_x_more} ) && $z == $self->{_x_more} ) {
break;
}
if( defined( $self->{_process_image} ) ) {
$self->write( 'm_href_w', #m_href_array );
$self->write( 'href_w', #href_array );
$self->write( 'error_w', #m_error_array );
}
$self->{_link_count} = scalar #m_href_array;
}
}
1;
#$query = "SELECT * FROM `actwebdesigns.co.uk` ORDER BY ID DESC";
#$result = $dbh->prepare($query);
#$result->execute();
#while( $array = $result->fetchrow_hashref() ) {
# print $array->{'URL'} . "\n";
#}
Your code probably won't work the way you think it will. Take, for example, this block:
}else{
my #m_error_array;
my #m_href_array;
my #href_array = ( $self->{_url} );
}
What this does is declare three arrays. That's all fine and good, but because you've used my, they "disappear" when they go out of scope at the end of the else{} block. You probably want to declare them up at the top, before your if...else block and remove the duplicated declarations from both blocks in the if...else section.
Then, you're probably trying to iterate over the #href_array list. You'll want to change your while() to something like:
foreach my $href_array ( #href_array ) {
...
}
All that said, kudos for putting use strict in your code (it must be there, or else you wouldn't have received the warning you did). That's an important thing that programmers new to Perl greatly benefit from, because it warns them about exactly this problem!
It means you are using an undeclared variable $href_array. You need to rewrite this line:
while( $href_array ){
to something like:
foreach my $element (#href_array) {
...although a bit more context is needed in this code to be able to understand what it is doing -- for example, you open a database connection in the scrape method ($dbh = ...), but never use it.
Your code includes while($href_array) but you don't declare a variable called $href_array.
You may have meant #href_array (these are not the same variable), although you don't seem to modify this array inside the loop.
In all these answers no one bothers to tell you that the strict pragma enforces some more stringent coding practices in Perl. See its docs for the details. We explain it fully in Learning Perl too :)
When you get a warning you don't understand, you can get more information with the diagnostics. Here's an example:
use strict;
use diagnostics;
while( $href ) { 1 };
Here's the extended error message:
Execution of /Users/brian/Desktop/t aborted due to compilation errors (#1)
(F) You've said "use strict" or "use strict vars", which indicates
that all variables must either be lexically scoped (using "my" or "state"),
declared beforehand using "our", or explicitly qualified to say
which package the global variable is in (using "::").

Resources