remove entries in perl array with specified value

Assume that in array @array_filtered:

my @array_filtered = ("your", "array", "here", 1, 3, 8, "here", 2, 5, 9, "sit", "here",3, 4, 7,"yes","now",8,1,7,6); #or my @array_filtered=qw(your array here 1 3 8 here 2 5 9 sit here 3 4 7 yes now 8 1 7 6) which uses Alternative Quotes(q, qq, qw, qx)

You want to remove entries that have value "here" or "now" and it's following 3 entries, you can use splice:

#!/usr/bin/perl
my @array_filtered = ("your", "array", "here", 1, 3, 8, "here", 2, 5, 9, "sit", "here",3, 4, 7,"yes","now",8,1,7,6);
my @search_for = ("here","now");
#return keys that have specified value, =~/!~ for regular expression, eq/ne for string, ==/!= for number. or use unless()/if(not()). use m{} instead of // if there's too much / in the expression and you're tired of using \/ to escape them.

$search_for_s=join('|',@search_for);
@index_all = grep { $array_filtered[$_] =~ /$search_for_s/ } 0..$#array_filtered;

for($i=0;$i<=$#index_all;$i++) {
@index_all_one = grep { $array_filtered[$_] =~ /$search_for_s/ } 0..$#array_filtered;
splice(@array_filtered,$index_all_one[0],4);
#print $indexone."\n"
}

print "@array_filtered"."\n";

The output is "your array sit yes 6".

PS:

  • For more info about perl regular expression(such as operators<m, s, tr> and their modifiers, complex regular expression cheat sheet<.\s\S\d\D\w\W[aeiou][^aeiou](foo|bar), \G, $, $&, $`, $'> and more), you can refer to this article.
  • The following is about perl alternative quotes:

q// is generally the same thing as using single quotes - meaning it doesn't interpolate values inside the delimiters.
qq// is the same as double quoting a string. It interpolates.
qw// return a list of white space delimited words. @q = qw/this is a test/ is functionally the same as @q = ('this', 'is', 'a', 'test')
qx// is the same thing as using the backtick operators.

perl tips

##system value
$count=`wc -l space_mail_info.txt | sed 's/ space_mail_info.txt//'`;
if ($count >= 1) {
system('cat space_mail_info.txt | /bin/mailx -s "SAs - Space Warning - please work with component owners to free space" test@example.com');
}
##arrays
#!/usr/bin/perl -w
my @animals = ("dog", "pig", "cat");
print "The last element of array \$animals is : ".$animals[$#animals]."\n";
print "@animals"."\n"; #will print values of array, delimitered by space
print $#animals."\n"; #the last key number of array, $#animals+1 is the number of array
if(@animals>2){
print "more than 2 animals found\n";
}
else{
print "less than 2 animals found\n"
}
foreach(@animals){
print $_."\n";
}
##hashes
my %fruit_color=("apple", "red", "banana", "yellow");
print "Color of banana is : ".$fruit_color{"banana"}."\n";

for $char (keys %fruit_color)
{
print("$char => $fruit_color{$char}\n");
}

##references
my $variables = {
scalar  =>  {
description => "single item",
sigil => '$',
},
array   =>  {
description => "ordered list of items",
sigil => '@',
},
hash    =>  {
description => "key/value pairs",
sigil => '%',
},
};
print "Scalars begin with a $variables->{'scalar'}->{'sigil'}\n";

##Files and I/O
open (my $passwd, "<", "/etc/passwd2") or die ("can  a not open");
while (<$passwd>) {
print $_ if $_ =~ "test";
}
close $passwd or die "$passwd: $!";
my $next = "doing a first";
$next =~ s/first/second/;
print $next."\n";

my $email = "testaccount\@doxer.org";
if ($email =~ /([^@]+)@(.+)/) {
print "Username is : $1\n";
print "Hostname is : $2\n";
}

##Subroutines
sub multiply{
my ($num1, $num2) = @_;
my $result = $num1 * $num2;
return $result;
}

my $result2 = multiply(3, 5);
print "3 * 5 = $result2\n";

##or
! system('date') or die("failed it"); #if a subroutine returns ok, it'll return 0
PS:

Resolved - print() on closed filehandle $fh at ./perl.pl line 6.

You may find that print sometimes won't work as expected in perl, for example:

[root@centos-doxer test]# cat perl.pl
#!/usr/bin/perl
use warnings;
open($fh,"test.txt");
select $fh;
close $fh;
print "test";

You may expect "test" to be printed, but actually you got error message:

print() on closed filehandle $fh at ./perl.pl line 6.

So how's this happened? Please see my explanation:

[root@centos-doxer test]# cat perl.pl
#!/usr/bin/perl
use warnings;
open($fh,"test.txt");
select $fh;
close $fh; #here you closed $fh filehandle, but you should now reset filehandle to STDOUT
print "test";

Now here's the updated script:

#!/usr/bin/perl
use warnings;
open($fh,"test.txt");
select $fh;
close $fh;
select STDOUT;
print "test";

This way, you'll get "test" as expected!

 

Oracle BI Publisher reports - send mail when filesystems getting full

Let's assume you have one Oracle BI Publisher report for filesystem checking. And now you want to write script for checking that report page and send mail to system admins when filesystems are getting full. As the default output of Oracle BI Publisher report needs javascript to work, and as you may know javascript is evil that wget/curl can not get them, so after log on, the next step you need to do is to find the html version's url of that report for you to use in your script(and the html page has all records when javascript one has only part of them):

BI_report_login

BI_export_html

 

Let's assume that the html's url is "http://www.example.com:9703/report.html", and the display of it was like the following:

bi report

Then here goes the script that will check this page for hosts that has less than 10% available space and send mail to system admins:

#!/usr/bin/perl
use HTML::Strip;
#hosts that do not need reporting
my @remove_list = qw(host1.example.com host2.example.com);
system("rm -f spacereport.html");
system("wget -q --no-proxy --no-check-certificate --post-data 'id=admin&passwd=password' 'http://www.example.com:9703/report.html' -O spacereport.html");
open($fh,"spacereport.html");

#or just @spacereport=<$fh>;
foreach(<$fh>){
push(@spacereport,$_);
}

#change array to hash
$index=0;
map {$pos{$index++}=$_} @spacereport;

#get location of <table> and </table>
#sort numerically ascending
for $char (sort {$a<=>$b} (keys %pos))
{
if($pos{$char} =~ /<table class="c27">/)
{
$table_start=$char;
}

if($pos{$char} =~ /<\/table>/)
{
$table_end=$char;
}

}

#get contents between <table> and </table>
for($i=$table_start;$i<=$table_end;$i++){
push(@table_array,$spacereport[$i]);
}

$table_htmlstr=join("",@table_array);

#get clear text between <table> and </table>
my $hs=HTML::Strip->new();
my $clean_text = $hs->parse($table_htmlstr);
$hs->eof;

@array_filtered=split("\n",$clean_text);

#remove empty array element
@array_filtered=grep { !/^\s+$/ } @array_filtered;

#remove entries from showing
$remove_list_s=join('|',@remove_list);
@index_all = grep { $array_filtered[$_] =~ /$remove_list_s/ } 0..$#array_filtered;

for($i=0;$i<=$#index_all;$i++) {
@index_all_one = grep { $array_filtered[$_] =~ /$remove_list_s/ } 0..$#array_filtered;
splice(@array_filtered,$index_all_one[0],4);
}

system("rm -f space_mail_warning.txt");
open($fh_mail_warning,">","space_mail_warning.txt");
select $fh_mail_warning;
for($j=4;$j<=$#array_filtered;$j=$j+4){
#put lines that has free space lower than 10% to space_mail_warning.txt
if($array_filtered[$j+2] <= 10){
print "Host: ".$array_filtered[$j]."\n";
print "Part: ".$array_filtered[$j+1]."\n";
print "Free(%): ".$array_filtered[$j+2]."\n";
print "Free(GB): ".$array_filtered[$j+3]."\n";
print "============\n\n";
}
}
close $fh_mail_warning;

system("rm -f space_mail_info.txt");
open($fh_mail_info,">","space_mail_info.txt");
select $fh_mail_info;
for($j=4;$j<=$#array_filtered;$j=$j+4){
#put lines that has free space lower than 15% to space_mail_info.txt
if($array_filtered[$j+2] <= 15){
print "Host: ".$array_filtered[$j]."\n";
print "Part: ".$array_filtered[$j+1]."\n";
print "Free(%): ".$array_filtered[$j+2]."\n";
print "Free(GB): ".$array_filtered[$j+3]."\n";
print "============\n\n";
}
}
close $fh_mail_info;

#send mail
#select STDOUT;
if(-s "space_mail_warning.txt"){
system('cat space_mail_warning.txt | /bin/mailx -s "Space Warning - please work with component owners to free space" sysadmins@example.com');
} elsif(-s "space_mail_info.txt"){
system('cat space_mail_info.txt | /bin/mailx -s "Space Info - Space checking mail" sysadmins@example.com');
}

Oracle VM operations - poweron, poweroff, status, stat -r

Here's the script:
#!/usr/bin/perl
#1.OVM must be running before operations
#2.run ovm_vm_operation.pl status before running ovm_vm_operation.pl poweroff or poweron
use Net::SSH::Perl;
$host = $ARGV[0];
$operation = $ARGV[1];
$user = 'root';
$password = 'password';

$newname=$ARGV[2];
$newcpu=$ARGV[3];
$newmemory=$ARGV[4];
$newpool=$ARGV[5];
$newtmpl=$ARGV[6];
$newbridge=$ARGV[7];
$newbridge2=$ARGV[8];
$newvif='vif0';
$newvif2='VIF1';

if($host eq "help") {
print "$0 OVM-name status|poweron|poweroff|reboot|stat-r|stat-r-all|pool|new vmname 1 4096 poolname tmplname FE BE\n";
exit;
}

$ssh = Net::SSH::Perl->new($host);
$ssh->login($user,$password);

if($operation eq "status") {
($stdout,$stderr,$exit) = $ssh->cmd("ovm -uadmin -ppassword vm ls|grep -v VM_test");
open($host_fd,'>',"/var/tmp/${host}.status");
select $host_fd;
print $stdout;
close $host_fd;
} elsif($operation eq "poweroff") {
open($poweroff_fd,'<',"/var/tmp/${host}.status");
foreach(<$poweroff_fd>){
if($_ =~ "Server_Pool|OVM|Powered") {
next;
}
if($_ =~ /(.*?)\s+([0-9]{1,})\s+([0-9]{1,})\s+([0-9]{1,})\s+([a-zA-Z]{1,})\s+(.*)/){
$ssh->cmd("ovm -uadmin -ppassword vm poweroff -n $1 -s $6 -f");
sleep 12;
}
}
} elsif($operation eq "reboot") {
open($poweroff_fd,'<',"/var/tmp/${host}.status");
foreach(<$poweroff_fd>){
if($_ =~ "Server_Pool|OVM|Powered") {
next;
}
if($_ =~ /(.*?)\s+([0-9]{1,})\s+([0-9]{1,})\s+([0-9]{1,})\s+([a-zA-Z]{1,})\s+(.*)/){
$ssh->cmd("ovm -uadmin -ppassword vm reboot -n $1 -s $6");
sleep 12;
}
}
} elsif($operation eq "poweron") {
open($poweron_fd,'<',"/var/tmp/${host}.status");
foreach(<$poweron_fd>){
if($_ =~ "Server_Pool|OVM|Running|used|poweroff") {
next;
}
if($_ =~ /(.*?)\s+([0-9]{1,})\s+([0-9]{1,})\s+([0-9]{1,})\s+([a-zA-Z]{1,})\s+Off(.*)/){
$ssh->cmd("ovm -uadmin -ppassword vm poweron -n $1 -s $6");
#print "ovm -uadmin -ppassword vm poweron -n $1 -s $6";
sleep 15;
}
}
} elsif($operation eq "stat-r") {
open($poweroff_fd,'<',"/var/tmp/${host}.status");
foreach(<$poweroff_fd>){
if($_ =~ /(.*?)\s+([0-9]{1,})\s+([0-9]{1,})\s+([0-9]{1,})\s+(Shutting\sDown|Initializing|Error|Unknown|Rebooting|Deleting)\s+(.*)/){
#print "ovm -uadmin -ppassword vm stat -r -n $1 -s $6";
$ssh->cmd("ovm -uadmin -ppassword vm stat -r -n $1 -s $6");
sleep 1;
}
}
} elsif($operation eq "stat-r-all") {
open($poweroff_fd,'<',"/var/tmp/${host}.status");
foreach(<$poweroff_fd>){
$ssh->cmd("ovm -uadmin -ppassword vm stat -r -n $1 -s $6");
sleep 1;
}
} elsif($operation eq "pool") {
($stdoutp,$stderrp,$exitp) = $ssh->cmd("ovm -uadmin -ppassword svrp ls|grep Inactive");
open($host_fdp,'>',"/var/tmp/${host}-poolstatus");
select $host_fdp;
print $stdoutp;
close $host_fdp;
} elsif($operation eq "new") {
($stdoutp,$stderrp,$exitp) = $ssh->cmd("ovm -uadmin -ppassword tmpl ls -s $newpool | grep $newtmpl");
if($stdoutp =~ /$newtmpl/){
($stdoutp2,$stderrp2,$exitp2) = $ssh->cmd("ovm -uadmin -ppassword vm new -m template -s $newpool -t $newtmpl -n $newname -c password");
if($stdoutp2 =~ /is being created/){
print "Creating VM $newname in pool $newpool on OVMM $host now!"."\n";
while(1){
($stdoutp3,$stderrp3,$exitp3) = $ssh->cmd("ovm -uadmin -ppassword vm stat -n $newname -s $newpool");
if($stdoutp3 =~ /Powered Off/){
print "Done VM creation."."\n";
last;
}
sleep 300
}

print "Setting Cpu/Memory now."."\n";
($stdoutp32,$stderrp32,$exitp32) = $ssh->cmd("ovm -uadmin -ppassword vm conf -n $newname -s $newpool -x $newmemory -m $newmemory -c $newcpu -P");
sleep 2;

print "Creating NICs now."."\n";
($stdoutp4,$stderrp4,$exitp4) = $ssh->cmd("ovm -uadmin -ppassword vm nic conf -n $newname -s $newpool -N $newvif -i VIF0 -b $newbridge");
sleep 2;
($stdoutp5,$stderrp5,$exitp5) = $ssh->cmd("ovm -uadmin -ppassword vm nic add -n $newname -s $newpool -N $newvif2 -b $newbridge2");
sleep 2;

print "Powering on VM now."."\n";
($stdoutp6,$stderrp6,$exitp6) = $ssh->cmd("ovm -uadmin -ppassword vm poweron -n $newname -s $newpool");
sleep 30;

while(1){
($stdoutp7,$stderrp7,$exitp7) = $ssh->cmd("ovm -uadmin -ppassword vm info -n $newname -s $newpool");
if($stdoutp7 =~ /Running on: sl/){
print "VM is now Running, you can configure VM on hypervisor now:"."\n";
print $stdoutp7."\n";
last;
}
sleep 30;
}

#($stdoutp8,$stderrp8,$exitp8) = $ssh->cmd("ovm -uadmin -ppassword vm ls -l | grep $newname");
#print "You can configure VM on hypervisor now:"."\n";
#print $stdoutp8."\n";
} else {
print $stdoutp2."\n";
exit;
}
} else {
print "No template named $newtmpl in pool $newpool\n";
exit;
}
}

You can use the following to make the script run in parallel:

for i in <all OVMs>;do (./ovm_vm_operation.pl $i status &);done

parallel execution of script using perl fork()

Let's assume that we want to test 100 hosts to see whether they're pingable or not. You may think of bash style for ... do ... done loop, but as that is executed one by one, so it's not efficient. And in this article, I'm going to create parallel execution of this task using perl's fork().

Firstly, here's one script to get whether one host is pingable or not:

[root@centos-doxer pping_doxer]# cat script.sh
#!/usr/bin/expect
log_user 0
match_max -d 2000000
set host [lindex [lrange $argv 0 0] 0]
spawn -noecho ping $host
set timeout 2
expect "bytes from" {exit 0} default {puts "not pingable from $host";exit 1}

Let's run it and see the result:

[root@centos-doxer pping_doxer]# ./script.sh test-host
not pingable from test-host

So now, let's write one perl script to wrapper this expect script, and also add parallel run to it:

#!/usr/bin/perl
our @hosts=("testhost0001","testhost00022","testhost00033","testhost0007");
#you can read a file to perl array too
#open($fh,"/doxer/projects/pping_doxer/servers.txt");
#our @hosts=<$fh>;
our $zombies = 0;
our $kid_proc_num = 0;

$SIG{CHLD} = sub { $zombies++ };
for(my $i=0; $i<@hosts; $i++) {
my $pid = fork();
if( !defined($pid) ) { exit 1; }
unless($pid) {
system("/doxer/projects/pping_doxer/script.sh $hosts[$i]"); #change the path according to your env
exit 0;
}
$kid_proc_num++;
}

while (1) {
if($zombies > 0) {
$zombies = 0;
my $collect;
while(($collect = waitpid(-1, WNOHANG)) > 0) {
$kid_proc_num--;
}
}
if($kid_proc_num==0) { last; }
else { next; }
}

And now let's have a test:

[root@centos-doxer pping_doxer]# ./pping_doxer
not pingable from testhost0001
not pingable from testhost00033
not pingable from testhost0007
not pingable from testhost00022

You can modify script.sh to fulfill your own aim except for ping of course.

That's it, enjoy!

PS:

1.I've wrote an updated version of pping_doxer, which allows you to specify a maximum number of parallel running processes and also puts hosts in a file. I've put the package in http://www.doxer.org/projects-doxer/, the package name is pping_doxer.

2.Thanks very much to http://www.ibm.com/developerworks/cn/linux/l-cn-perlmp/.

understanding perl fork

Let's go through perl fork() by example:

#!/usr/bin/perl -w
use strict;

defined(my $pid=fork()) or die "Fork process failured:$!\n";  #two processes are running now, one parent and child process($pid is zero)
unless($pid)
{
# This is the child process.
system "date";
sleep(3);
print ("Exit child after 3 seconds wait!\n");
exit();
}
# This is the parent process.
waitpid($pid,0);
system "date";
print ("exit parent!\n");

Here's the result:

Tue Jul 2 18:29:33 CST 2013
Exit child after 3 seconds wait!
Tue Jul 2 18:29:36 CST 2013
exit parent!

And now let's test when waitpid() is commented out:

#!/usr/bin/perl -w
use strict;

defined(my $pid=fork()) or die "Fork process failured:$!\n";
unless($pid)
{
# This is the child process.
system "date";
sleep(3);
print ("Exit child after 3 seconds wait!\n");
exit();
}
# This is the parent process.
#waitpid($pid,0);  #parent no longer wait until child process exit
system "date";
print ("exit parent!\n");

And here's the result:

[root@centos-doxer test]# ./perl.test
Tue Jul 2 18:30:05 CST 2013
Tue Jul 2 18:30:05 CST 2013
exit parent!

perl tips - most useful perl command line options switches

Here's all perl command line options, red ones are the most useful ones from me:

[root@centos-doxer test]# perl --help
Usage: perl [switches] [--] [programfile] [arguments]

-c check syntax only (runs BEGIN and CHECK blocks) #perl -c ./perl.pl

-e program one line of program (several -e's allowed, omit programfile) #e.g. perl -e 'print "hi\n";print "hi again\n";'

-n assume "while (<>) { ... }" loop around program #like -p, but do not print

-p assume loop like -n but print line also, like sed #perl -p -e "tr/[a-z]/[A-Z]/" a.txt

-i[extension] edit <> files in place (makes backup if extension supplied) #perl -pi.bak -e "tr/[a-z]/[A-Z]/" a.txt

-[mM][-]module execute "use/no module..." before executing program #perl -MCPAN -e 'install xxx:xxx'

-l[octal] enable line ending processing, specifies line terminator #man ascii to see all ascii - octal mapping

-F/pattern/ split() pattern for -a switch (//'s are optional)

-a autosplit mode with -n or -p (splits $_ into @F) #perl -n -l072 -a -F/:/ -e 'print $F[0]' a.txt

 

-s enable rudimentary parsing for switches after programfile 

[root@centos-doxer test]# cat perl.test
#!/usr/bin/perl -s
print "yes\n" if defined($r);
print "no\n" unless defined($r);

[root@centos-doxer test]# ./perl.test -a
no
[root@centos-doxer test]# ./perl.test test
no
[root@centos-doxer test]# ./perl.test -r
yes

xm list|awk '{print $1}'|perl -p -e "s/^.*(slce.*?)_.*/\1/g" #will return slce09vm001

ovm vm ls|awk '{print $1}'|perl -p -e "s/^[0-9]{2,}_(.*)/\1/g"|perl -p -e "s/^.*(slc.*?)[_-].*/\1/g"|egrep -v 'wlsaas|virt'|grep slc|sort #will return slce09vm001

-C[number/list] enables the listed Unicode features
-0[octal] specify record separator (\0, if no argument)
-d[:debugger] run program under debugger
-D[number/list] set debugging flags (argument is a bit mask or alphabets)
-f don't do $sitelib/sitecustomize.pl at startup
-Idirectory specify @INC/#include directory (several -I's allowed)
-P run program through C preprocessor before compilation

-S look for programfile using PATH environment variable
-t enable tainting warnings
-T enable tainting checks
-u dump core after parsing program
-U allow unsafe operations
-v print version, subversion (includes VERY IMPORTANT perl info)
-V[:variable] print configuration summary (or a single Config.pm variable)
-w enable many useful warnings (RECOMMENDED)
-W enable all warnings
-x[directory] strip off text before #!perl line and perhaps cd to directory
-X disable all warnings

perl - match fixed number of spaces or other characters

Sometimes you want to match lines beginning with exactly four spaces("<space><space><space><space>") :

<space><space><space><space><space>Line1

<space><space><space><space>Line2  --only this line!

<space><space>Line3

So here's the perl script to fulfill this:

#!/usr/bin/perl
open($fdme, '/doxer/test/a.txt');
foreach(<$fdme>){
if($_ =~ /^\s{4}\w+.*/){
print $_."\n";
}
}

install perl module using tarball or cpan

To install a perl module using cpan:
Method 1:
PERL_MM_USE_DEFAULT=1
export PERL_MM_USE_DEFAULT=1
cpan> o conf prerequisites_policy follow
cpan> o conf build_requires_install_policy yes
cpan> o conf commit
cpan > o conf init /proxy/
cpan> force install Net::SSH::Perl
Method 2:
PERL_MM_USE_DEFAULT=1
perl -MCPAN -e 'install Net::SSH::Perl'
To install a perl module using yum in Linux:
yum install -y "perl(X11::Protocol)"
To manually install a Perl module:
1. Download the Perl module from CPAN or other site.
2. Extract the tarball.
3. Run perl Makefile.PL
4. Run make
5. Run make test
6. Run make install

 

To test whether the module has been installed or not, run this:

perl -e 'use Module::Metadata', if nothing returned, then it's ok

PS:
  • yum install perl-CPAN if you found that cpan was not installed by default with perl
  • Here's help message for cpan:
cpan> help #o conf init to reconfigure cpan
Display Information
 command  argument          description
 a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
 i        WORD or /REGEXP/  about anything of above
 r        NONE              reinstall recommendations
 ls       AUTHOR            about files in the author's directory
 
Download, Test, Make, Install...
 get                        download
 make                       make (implies get)
 test      MODULES,         make test (implies make)
 install   DISTS, BUNDLES   make install (implies test)
 clean                      make clean
 look                       open subshell in these dists' directories
 readme                     display these dists' README files
 
Other
 h,?           display this menu       ! perl-code   eval a perl command
 o conf [opt]  set and query options   q             quit the cpan shell
 reload cpan   load CPAN.pm again      reload index  load newer indices
 autobundle    Snapshot                force cmd     unconditionally do cmd