Perl autoflush

My Timer script

2023.03.11 04:26 East-Barnacle-7473 My Timer script

This is timers.pl

#!/usbin/perl #timers.pl #This is perl 5, version 32, subversion 1 (v5.32.1) #built for amd64-openbsd use warnings; use strict; # Store User Seconds my $Seconds = ""; # Store System String my $cmdString = ""; # How many timers do you want get input print "How Many Timers:"; my $timers = ; for(my $i = 1; $i <= $timers ; $i++){ # How many Seconds for Timer get user input print "\nHow Many Seconds for Timer $i:"; $Seconds = ; print $Seconds; # Remove any NewLines or Cartage Returns # Tailing '&' isn't on a newline causes a sh error $Seconds =~ s/\n//g; $Seconds =~ s/\/g; # Command String to pass to system $cmdString = "perl ~/perls/timer.pl $i $Seconds &\n"; system($cmdString); }

I was using perlfaq8(1) background process exhausted my search for a answer. I asked reddit then realized left a CR on my variable. I would print the variable it would always create a newline.
This is my timer.pl

#!/usbin/perl #timer.pl #This is perl 5, version 32, subversion 1 (v5.32.1) use warnings; use strict; # Set Autoflush Realtime not Endline for print # Not needed for this silent example #local $ = 1; # Check Argument total that were passed # $#ARG, $ARGV[0], $ARGV[1], is a perl variable if($#ARGV < 1){ print "Error 1: Timer Name or Timer Seconds Not Set"; }else{ #Call Sub timer #1st Argument is Timer Name #2nd Argument Timer Seconds timer($ARGV[0],$ARGV[1]); } sub timer{ # Hold Elapsed Seconds my $ElapsedTime = 0; # Set Start Time my $StartTime = time(); my $CurrentTime = time(); #Compare ElapsedTime to Second Argument(Total Seconds) while($ElapsedTime <= $_[1]) { #Update only on seconds have changed #Helps with printing so no duplicate numbers if($ElapsedTime != ($CurrentTime - $StartTime)) { # Unremark to Print a number of passed Seconds, except 0 #if($ElapsedTime != 0){print "(",$ElapsedTime,")";} $ElapsedTime = $CurrentTime - $StartTime; } # Update Current Time $CurrentTime = time(); } # Print Timer Name End Status print "\n\n***Timer $_[0] has ended***\n\n"; return 0; }

I am a hobbyist not a expert just goofing off. I recommend learning from briandfoy.

submitted by East-Barnacle-7473 to perl [link] [comments]

2019.02.17 20:35 ronasimi How to strip characters from perl script output?

Hello perl gurus,

I'm currently using the following perl script to display my i3 desktops in lemonbar. I copied this from someone's github, and I don't know perl at all. In my i3 config, the desktops are named eg: "1: code". What's the simplest way in perl to strip the leading number and colon from the output?

#!/usbin/env perl
# vim:ts=4:sw=4:expandtab:ft=perl
#
# Print i3 workspaces on every change.
#
# Format:
# For every workspace (x = workspace name)
# - "FOCx" -> Focused workspace
# - "INAx" -> Inactive workspace
# - "ACTx" -> Ative workspace
# - "URGx" -> Urgent workspace
#
# Uses AnyEvent I3 0.8 -> https://metacpan.org/module/AnyEvent::I3
# Based in i3-wsbar of Michael Stapelberg -> http://code.stapelberg.de/git/i3/tree/contrib/i3-wsbar
#
# 16 feb 2015 - Electro7

use strict;
use warnings;
use AnyEvent::I3;
use AnyEvent;
use v5.10;
use open ':std', ':encoding(UTF-8)';

my $socket_path = undef;
my ( $workspaces, $outputs ) = ( [], {} );
my $w = AnyEvent->timer(
after => 3,
cb => sub {
die "Connection to i3 timed out. Verify socket path ($socket_path)";
exit 1;
}
);

my $i3 = i3($socket_path);

# Disable buffering
$ = 1;
STDERR->autoflush;
STDOUT->autoflush;

# Wait a short amount of time and try to connect to i3 again
sub reconnect {
print "reconecting\n";
my $timer;
$i3 = i3($socket_path);
if ( !defined($w) ) {
$w = AnyEvent->timer(
after => 3,
cb => sub {
die
"Connection to i3 timed out. Verify socket path ($socket_path)";
exit 1;
}
);
}

my $c = sub {
$timer = AnyEvent->timer(
after => 0.01,
cb => sub { $i3->connect->cb( \&connected ) }
);
};
$c->();
}

# Connection attempt succeeded or failed
sub connected {
my ($cv) = @_;

if ( !$cv->recv ) {
reconnect();
return;
}

$w = undef;

$i3->subscribe(
{
workspace => \&ws_change,
output => \&output_change,
_error => sub { reconnect() }
}
);
ws_change();
output_change();
}

# Called when a ws changes
sub ws_change {

# Request the current workspaces and update the output afterwards
$i3->get_workspaces->cb(
sub {
my ($cv) = @_;
$workspaces = $cv->recv;
update_output();
}
);
}

# Called when the reply to the GET_OUTPUTS message arrives
sub got_outputs {
my $reply = shift->recv;
my %new = map { ( $_->{name}, $_ ) } grep { $_->{active} } @{$reply};

for my $name ( keys %new ) {
$outputs->{$name} = $new{$name};
}

update_output();
}

sub output_change {
$i3->get_outputs->cb( \&got_outputs );
}

sub update_output {
my $out;

for my $name ( keys %{$outputs} ) {
$out .= "WSP";

for my $ws ( @{$workspaces} ) {
my $state = "INA";
$state = "ACT" if $ws->{visible};
$state = "URG" if $ws->{urgent};
$state = "FOC" if $ws->{focused};
my $name = $ws->{name};
$out .= qq$state$name ;
}

$out .= "\n";

print $out;
}
}

$i3->connect->cb( \&connected );

# let AnyEvent do the rest ("endless loop")
AnyEvent->condvar->recv

submitted by ronasimi to perl [link] [comments]

2017.10.13 14:49 Klousk Problem with Postfix randomizer

CentOS 6.6 perl 5
I've been having some problem using a perl script to randomize some postfix smtp.
I kept getting the error Magic number checking on storable file failed, so after some research I thought I found the error that was in this line
my $hash = retrieve($hashfile);
So I added an error handler like this:
eval { retrieve($hashfile) }; my $hash = ($@ ? {} : retrieve($hashfile));
Is this correct ? I still keep getting the error though, but it's way less and always together with Temporary failure storing.
From the error I'm inclined to add the same error "treatment" with in the store line, but I really don't understand how I keep getting the retrieve error.
Another doubt:
store {}, $hashfile unless -r $hashfile;
What does this -r flag stands for ? Can't really find anything online for it.
Thank you for reading.
Full code below (if that interests you):

#!/usbin/perl -w # author: Hari Hendaryanto  use strict; use warnings; use Sys::Syslog qw(:DEFAULT setlogsock); use List::Util::WeightedRoundRobin; use Storable; my $hashfile="/tmp/file.hash"; store {}, $hashfile unless -r $hashfile; # # our transports lists, we will define this in master.cf as transport services # Queued using Weighted Round-Robin Scheduling # my $list = [ { name => 'smtp1:', weight => 5, }, { name => 'smtp2:', weight => 5, }, { name => 'smtp3:', weight => 5, }, { name => 'smtp4:', weight => 5, }, { name => 'smtp5:', weight => 5, }, { name => 'smtp6:', weight => 5, }, { name => 'smtp7:', weight => 5, }, { name => 'smtp8:', weight => 5, }, { name => 'smtp9:', weight => 5, }, { name => 'smtp10:', weight => 5, }, ]; my $WeightedList = List::Util::WeightedRoundRobin->new(); my $weighted_list = $WeightedList->create_weighted_list( $list ); # $maxinqueue max number of queue in smtp list my $maxinqueue = scalar(@{$weighted_list}); # # Initalize and open syslog. # openlog('postfix/randomizer','pid','mail'); # # Autoflush standard output. # select STDOUT; $++; while (<>) { chomp; my $count; eval { retrieve($hashfile) }; my $hash = ($@ ? {} : retrieve($hashfile)); if (!defined $hash->{"index"}) { $count = 0; } else { $count = $hash->{"index"}; } if ($count >= $maxinqueue) { $hash->{"index"} = 0; $count = 0; } $hash->{"index"}++; store $hash, $hashfile; my $random_smtp = ${$weighted_list}[$count]; if (/^get\s(.+)$/i) { print "200 $random_smtp\n"; syslog("info","Using: %s Transport Service", $random_smtp); next; } print "200 smtp:\n"; }

submitted by Klousk to perl [link] [comments]

2016.01.29 21:37 myhusbandclaims Can someone help translate this perl script into js?

I'm having a bit of issues with the hex and the conversions not being too versed in perl. I'm having the most trouble with the data formats. Please help?

#!/usbin/perl -w # # Based on # http://forums.ninjablocks.com/index.php? # p=/discussion/2931/aldi-remote-controlled-power-points-5-july-2014/p1 # and # http://pastebin.ca/2818088 # and # https://github.com/franc-cartebauhn-wifi/blob/mastebauhn.pl # # Tuned for Orvibo S20 by Branislav Vartik use strict; use IO::Socket; use IO::Select; use Data::Dumper; use Net::Ping; use Net::ARP; my $debug = 1; # Change this to 0 to avoid debug messages my $port = 10000; my $fbk_preamble = pack('C*', (0x68,0x64,0x00,0x1e,0x63,0x6c)); my $ctl_preamble = pack('C*', (0x68,0x64,0x00,0x17,0x64,0x63)); my $ctl_on = pack('C*', (0x00,0x00,0x00,0x00,0x01)); my $ctl_off = pack('C*', (0x00,0x00,0x00,0x00,0x00)); my $twenties = pack('C*', (0x20,0x20,0x20,0x20,0x20,0x20)); my $onoff = pack('C*', (0x68,0x64,0x00,0x17,0x73,0x66)); my $subscribed = pack('C*', (0x68,0x64,0x00,0x18,0x63,0x6c)); sub findS20($) { my ($mac) = @_; my $s20; my $reversed_mac = scalar(reverse($mac)); my $subscribe = $fbk_preamble.$mac.$twenties.$reversed_mac.$twenties; my $socket = IO::Socket::INET->new(Proto=>'udp', LocalPort=>$port, Broadcast=>1) die "Could not create listen socket: $!\n"; $socket->autoflush(); my $select = IO::Select->new($socket) die "Could not create Select: $!\n"; my $iaddr = inet_aton($ARGV[0]) die 'Unable to resolve'; my $to_addr = sockaddr_in($port, $iaddr); $socket->send($subscribe, 0, $to_addr) die "Send error: $!\n"; my $n = 1; while($n <= 3) { print "DEBUG: Waiting for status $n\n" if $debug; my @ready = $select->can_read(1); foreach my $fh (@ready) { my $packet; my $from = $socket->recv($packet,1024) die "recv: $!"; if ((substr($packet,0,6) eq $subscribed) && (substr($packet,6,6) eq $mac)) { my ($port, $iaddr) = sockaddr_in($from); $s20->{mac} = $mac; $s20->{saddr} = $from; $s20->{socket} = $socket; $s20->{on} = (substr($packet,-1,1) eq chr(1)); return $s20; } } $n++; } close($socket); return undef; } sub controlS20($$) { my ($s20,$action) = @_; my $mac = $s20->{mac}; if ($action eq "on") { $action = $ctl_preamble.$mac.$twenties.$ctl_on; } if ($action eq "off") { $action = $ctl_preamble.$mac.$twenties.$ctl_off; } print $action,"\n"; my $select = IO::Select->new($s20->{socket}) die "Could not create Select: $!\n"; my $n = 0; while($n < 2) { $s20->{socket}->send($action, 0, $s20->{saddr}) die "Send error: $!\n"; my @ready = $select->can_read(0.5); foreach my $fh (@ready) { my $packet; my $from = $s20->{socket}->recv($packet,1024) die "recv: $!"; my @data = unpack("C*", $packet); my @packet_mac = @data[6..11]; if (($onoff eq substr($packet,0,6)) && ($mac eq substr($packet,6,6))) { return 1; } } $n++; } return 0; } my $usage = "Usage: $0   \n"; print "arguments: \t$#ARGV \t"; ($#ARGV == 1) die $usage; my $ip = $ARGV[0]; my $command = $ARGV[1]; my $TargetMac = Net::ARP::arp_lookup("eth0",$ip); my @mac = split(':',$TargetMac ); # my @mac = split('.', $ARGV[1]); ($#mac == 5) die $usage; @mac = map { hex("0x".$_) } split(':', $TargetMac); my $mac = pack('C*', @mac); my $n = 1; my $p = Net::Ping->new('icmp', 1); do { print "DEBUG: Ping $n\n" if $debug; ( $n == 10 ) && die "Could not ping S20 with IP of $ip\n"; $n++; } until ($p->ping($ip)); $p->close(); my $s20 = findS20($mac); unless (defined($s20)) { print "DEBUG: Sleeping for retry\n" if $debug; sleep(1); $s20 = findS20($mac); defined($s20) die "Could not find S20 with mac of $mac\n"; } if ($command eq "status") { print $s20->{on} ? "on\n" : "off\n"; exit(0); } ($command ne "on" && $command ne "off") && die $usage; for(my $n=1; $n<=3; $n++) { print "DEBUG: Waiting for confirmation $n\n" if $debug; controlS20($s20, $command) && exit(0); # FIXME: Print DEBUG info } die "Could not change S20 to $command\n";

submitted by myhusbandclaims to perl [link] [comments]

2016.01.29 21:23 myhusbandclaims Can someone help translate this perl script into js?

I'm having a bit of issues with the hex and the conversions not being too versed in perl. I'm having the most trouble with the data formats. Please help?

#!/usbin/perl -w # # Based on # http://forums.ninjablocks.com/index.php? # p=/discussion/2931/aldi-remote-controlled-power-points-5-july-2014/p1 # and # http://pastebin.ca/2818088 # and # https://github.com/franc-cartebauhn-wifi/blob/mastebauhn.pl # # Tuned for Orvibo S20 by Branislav Vartik use strict; use IO::Socket; use IO::Select; use Data::Dumper; use Net::Ping; use Net::ARP; my $debug = 1; # Change this to 0 to avoid debug messages my $port = 10000; my $fbk_preamble = pack('C*', (0x68,0x64,0x00,0x1e,0x63,0x6c)); my $ctl_preamble = pack('C*', (0x68,0x64,0x00,0x17,0x64,0x63)); my $ctl_on = pack('C*', (0x00,0x00,0x00,0x00,0x01)); my $ctl_off = pack('C*', (0x00,0x00,0x00,0x00,0x00)); my $twenties = pack('C*', (0x20,0x20,0x20,0x20,0x20,0x20)); my $onoff = pack('C*', (0x68,0x64,0x00,0x17,0x73,0x66)); my $subscribed = pack('C*', (0x68,0x64,0x00,0x18,0x63,0x6c)); sub findS20($) { my ($mac) = @_; my $s20; my $reversed_mac = scalar(reverse($mac)); my $subscribe = $fbk_preamble.$mac.$twenties.$reversed_mac.$twenties; my $socket = IO::Socket::INET->new(Proto=>'udp', LocalPort=>$port, Broadcast=>1) die "Could not create listen socket: $!\n"; $socket->autoflush(); my $select = IO::Select->new($socket) die "Could not create Select: $!\n"; my $iaddr = inet_aton($ARGV[0]) die 'Unable to resolve'; my $to_addr = sockaddr_in($port, $iaddr); $socket->send($subscribe, 0, $to_addr) die "Send error: $!\n"; my $n = 1; while($n <= 3) { print "DEBUG: Waiting for status $n\n" if $debug; my @ready = $select->can_read(1); foreach my $fh (@ready) { my $packet; my $from = $socket->recv($packet,1024) die "recv: $!"; if ((substr($packet,0,6) eq $subscribed) && (substr($packet,6,6) eq $mac)) { my ($port, $iaddr) = sockaddr_in($from); $s20->{mac} = $mac; $s20->{saddr} = $from; $s20->{socket} = $socket; $s20->{on} = (substr($packet,-1,1) eq chr(1)); return $s20; } } $n++; } close($socket); return undef; } sub controlS20($$) { my ($s20,$action) = @_; my $mac = $s20->{mac}; if ($action eq "on") { $action = $ctl_preamble.$mac.$twenties.$ctl_on; } if ($action eq "off") { $action = $ctl_preamble.$mac.$twenties.$ctl_off; } print $action,"\n"; my $select = IO::Select->new($s20->{socket}) die "Could not create Select: $!\n"; my $n = 0; while($n < 2) { $s20->{socket}->send($action, 0, $s20->{saddr}) die "Send error: $!\n"; my @ready = $select->can_read(0.5); foreach my $fh (@ready) { my $packet; my $from = $s20->{socket}->recv($packet,1024) die "recv: $!"; my @data = unpack("C*", $packet); my @packet_mac = @data[6..11]; if (($onoff eq substr($packet,0,6)) && ($mac eq substr($packet,6,6))) { return 1; } } $n++; } return 0; } my $usage = "Usage: $0   \n"; print "arguments: \t$#ARGV \t"; ($#ARGV == 1) die $usage; my $ip = $ARGV[0]; my $command = $ARGV[1]; my $TargetMac = Net::ARP::arp_lookup("eth0",$ip); my @mac = split(':',$TargetMac ); # my @mac = split('.', $ARGV[1]); ($#mac == 5) die $usage; @mac = map { hex("0x".$_) } split(':', $TargetMac); my $mac = pack('C*', @mac); my $n = 1; my $p = Net::Ping->new('icmp', 1); do { print "DEBUG: Ping $n\n" if $debug; ( $n == 10 ) && die "Could not ping S20 with IP of $ip\n"; $n++; } until ($p->ping($ip)); $p->close(); my $s20 = findS20($mac); unless (defined($s20)) { print "DEBUG: Sleeping for retry\n" if $debug; sleep(1); $s20 = findS20($mac); defined($s20) die "Could not find S20 with mac of $mac\n"; } if ($command eq "status") { print $s20->{on} ? "on\n" : "off\n"; exit(0); } ($command ne "on" && $command ne "off") && die $usage; for(my $n=1; $n<=3; $n++) { print "DEBUG: Waiting for confirmation $n\n" if $debug; controlS20($s20, $command) && exit(0); # FIXME: Print DEBUG info } die "Could not change S20 to $command\n";

submitted by myhusbandclaims to learnjavascript [link] [comments]

2015.03.07 01:27 ccie6861 Perl appears to be processing out of order. Help.

I have a simple perl script that leverages the expect module. The purpose is to automate simple repetitive configuration changes or data collection on network equipment. The code is solid and has gone through a dozen revisions over almost ten years. Today I found a problem and I don't really have an explanation for it other than the code is being evaluated out of order.
UPDATE: I tried disabling buffering using the $++; and $expect->output_autoflush(1); to no help. I then enabled the debugs as suggested. Output didn't mean much to me. I've posted it below. The last thing I tried was ensuring the last expect session was closed before opening a new one (previously the subroutine was called recursively, so multiple sessions could be open at once). This caused the symptom to disappear.
OS: Centos 2.6.18-402.el5
Perl Version: 5.8.8 i386
Expect Version: 5.43.0-8.el5
code:

185 $telnet->clear_accum(); 186 print $telnet "\r"; 187 unless ($telnet->expect(30,"$device_prompt")) { print $telnet->exp_before(); die; } 188 189 if($auto_save) { 190 print $telnet "write memory\r"; 191 unless ($telnet->expect(30,"$device_prompt")) { die; } 192 } 192 194 print $telnet "exit\r";

output:

SWITCH# SWITCH#write memory Building configuration... [OK] SWITCH#exit Connection to 10.1.1.1 closed. exit Connection to 10.1.1.1 closed. Died at ./port_by_mac.pl line 187.

New debug output:

Starting EXPECT pattern matching... at /uslib/perl5/site_perl/5.8.8/Expect.pm line 561 Expect::expect('Expect=GLOB(0x92d3f08)', 30, 'LESSW17#') called at ./port_by_mac.pl line 196 main::get_port(10.8.0.17, '08ea.447e.2e40', 'AH-7e2e40') called at ./port_by_mac.pl line 185 main::get_port(10.8.0.18, '08ea.447e.2e40', 'AH-7e2e40') called at ./port_by_mac.pl line 185 main::get_port(10.8.0.1, '08ea.447e.2e40', 'AH-7e2e40') called at ./port_by_mac.pl line 89 LESSW17#write memory Building configuration... [OK] LESSW17#Starting EXPECT pattern matching... at /uslib/perl5/site_perl/5.8.8/Expect.pm line 561 Expect::expect('Expect=GLOB(0x92d3f08)', 30, 'LESSW17#') called at ./port_by_mac.pl line 196 main::get_port(10.8.0.18, '08ea.447e.2e40', 'AH-7e2e40') called at ./port_by_mac.pl line 185 main::get_port(10.8.0.1, '08ea.447e.2e40', 'AH-7e2e40') called at ./port_by_mac.pl line 89 exit Connection to 10.8.0.17 closed. Closing spawn id(4). at /uslib/perl5/site_perl/5.8.8/Expect.pm line 1431 Expect::hard_close('Expect=GLOB(0x92d3f08)') called at /uslib/perl5/site_perl/5.8.8/Expect.pm line 894 Expect::_multi_expect(30, 'undef', 'ARRAY(0x92d4124)') called at /uslib/perl5/site_perl/5.8.8/Expect.pm line 565 Expect::expect('Expect=GLOB(0x92d3f08)', 30, 'LESSW17#') called at ./port_by_mac.pl line 196 main::get_port(10.8.0.18, '08ea.447e.2e40', 'AH-7e2e40') called at ./port_by_mac.pl line 185 main::get_port(10.8.0.1, '08ea.447e.2e40', 'AH-7e2e40') called at ./port_by_mac.pl line 89 spawn id(4) closed. exit Connection to 10.8.0.17 closed. Died at ./port_by_mac.pl line 197. Closing spawn id(4). at /uslib/perl5/site_perl/5.8.8/Expect.pm line 1431 Expect::hard_close('Expect=GLOB(0x92d3f08)') called at /uslib/perl5/site_perl/5.8.8/Expect.pm line 1621 Expect::DESTROY('Expect=GLOB(0x92d3f08)') called at ./port_by_mac.pl line 0 eval {...} called at ./port_by_mac.pl line 0

The output pretty clearly suggests that the "print exit" command on line 194 is being executed before the unless is evaluated on line 187.
The word "exit" exists in one an only one location in this code and there is no loop inside of the expect session handle. The underlying transport is SSH (despite the handle being called $telnet).
Lastly, this happens consistently on one switch I connect to, but most work just fine.
What am I missing here?

submitted by ccie6861 to perl [link] [comments]

http://activeproperty.pl/