Perl Regex named capture variables

Simple example to extract, protocol, server and domain from a given URL:

my $test = "http:www.test.com";

$test =~ /^(?<protocol>.+)\:(?<server>.+)\.(?<domain>.+)$/;

print "protocol : ".$+{protocol}."\n";
print "Server   : ".$+{server}."\n";
print "Domain   : ".$+{domain}."\n";

Our Result:

sh-4.3$ perl main.pl 
protocol : http      
Server   : www.test 
Domain   : com

Perl find all pow 2 numbers

This little script finds all pow 2 numbers in Perl :

use strict;
my $number = 0;

for(1..32){
    ++$number;
    print "$number - ".isPow2($number)."\n";
}


sub isPow2 {
    return(0) if($_[0] <= 0);
    return(1) if($_[0] == 1);
    for(1..$_[0]){
       return(1) if($_[0] == 2**$_)
    }
    return(0);
}

Our Result:

1 - 1  
2 - 1  
3 - 0  
4 - 1  
5 - 0  
6 - 0  
7 - 0  
8 - 1  
9 - 0  
10 - 0 
11 - 0 
12 - 0 
13 - 0 
14 - 0 
15 - 0 
16 - 1

Perl print String difference

This function prints the difference between two strings with Perl:

sub printStringDiff{
my ($s1, $s2) = @_;

my @s1 = split(//, $s1);
my @s2 = split(//, $s2);
while (@s1) {

    if (defined $s1[0] and defined $s2[0]) {
    	if($s1[0] eq $s2[0]){
			print shift @s1;
		}else{
			print color("red"),shift @s1, color("reset");
		}
    }elsif(defined $s1[0]){
    	print color("red"),shift @s1, color("reset");
    }
    shift @s2;
}
print "\n";

@s1 = split(//, $s1);
@s2 = split(//, $s2);
while (@s2) {

    if (defined $s2[0] and defined $s1[0]) {
		if($s2[0] eq $s1[0]){
			print shift @s2;
		}else{
			print color("red"),shift @s2, color("reset");
		}
    }elsif(defined $s2[0]){
    	print color("red"),shift @s2, color("reset");
    }
    shift @s1;
}
print "\n";
}

You need the Module Term::ANSIColor, to highlight the changes,use it like this:

#!/usr/bin/perl
use strict;
use Term::ANSIColor;

printStringDiff("1234","123456");
print "\n";

printStringDiff("123456","1234");
print "\n";

printStringDiff("ABAA","AABA");
print "\n";

And the Result is :

ColorStringDiff

Perl check if file handler is open

If you write a function in Perl and want to check if the file handler is already open you could use this function:

sub filehandlerOpen {
	my $fh = shift;
	no warnings 'uninitialized';
	return 0 if(!defined $fh || $fh !~ /^GLOB\(0x.+?\)$/);
	if(fileno($fh) >= 1){
		return(1);
	}
	return(0);
}

It returns 0 if its undefined,closed or not open, an 1 if the handler is open.

 

In this little example I open a file to read and another to write, I check the sub before and after the open function, and before and after the close function.

#!/usr/bin/perl
use warnings;
use strict;

my ($fh_read,$fh_write);

print "Check undefined:\n";
print filehandlerOpen($fh_read).$/;
print filehandlerOpen($fh_write).$/;


open($fh_write, ">", './testfile') or die "Failed to open file: $!\n";
open($fh_read, "<", './testfile') or die "Failed to open file: $!\n";


print "Check defined:\n";
print filehandlerOpen($fh_read).$/;
print filehandlerOpen($fh_write).$/;


for my $num (1..6){
	print $fh_write "$num\n";
}
print "Check close write:\n";
print filehandlerOpen($fh_write).$/;
close($fh_write);
print filehandlerOpen($fh_write).$/;


while (my $row = <$fh_read>) {
  chomp $row;
}
print "Check close read:\n";
print filehandlerOpen($fh_read).$/;
close($fh_read);
print filehandlerOpen($fh_read).$/;


sub filehandlerOpen {
	my $fh = shift;
	no warnings 'uninitialized';
	return 0 if(!defined $fh || $fh !~ /^GLOB\(0x.+?\)$/);
	if(fileno($fh) >= 1){
		return(1);
	}
	return(0);
}

The Result, looks like expected:

Check undefined:
0
0
Check defined:
1
1
Check close write:
1
0
Check close read:
1
0

Perl print __DATA__ multiple times

Sometimes you have a lot of Data in Perl and you want to store in your script, for that you could you the __DATA__ token, you could simple read it with a file handle:

print <DATA>,"\n";

__DATA__
Test String
123456

If you use it more than one time you should seek for the start position:

#!/usr/bin/perl
use warnings;
use strict;



my $data_start = tell DATA; # where __DATA__ begins
print <DATA>,"\n";
seek DATA, $data_start, 0;

print <DATA>,"\n";

__DATA__
Test String
123456

Output looks like this:

Test String
123456

Test String
123456

Perl read/write File

This is a simple example how to write into a File with Perl, and then read from it.At first we write the numbers from 1 to 6 into the file, in the second we read from the file and print it on the screen, if you don’t want the “\n” at the end use the function chomp.

If you open a File for read use ‘<‘, for write ‘>’ and for append ‘>>’.

#!/usr/bin/perl
use warnings;
use strict;

#declare filehandler
my ($fh_read,$fh_write);


#open file for write
open($fh_write, ">", './testfile') or die "Failed to open file: $!\n";

#now write
for my $num (1..6){
	print $fh_write "$num\n";
}

#close the file
close($fh_write);


#open file for read
open($fh_read, "<", './testfile') or die "Failed to open file: $!\n";

#now read
while (my $row = <$fh_read>) {
  print $row;
}

#close the file
close($fh_read);

Result looks like:

1
2
3
4
5
6

you could check if a handler is open with this Perl handler function.

Fraction calculation in Perl

This Perl script is able to add,subtract,divide and multiply fractional numbers:

use strict;
#test data:
my @B1 = _read();
my @B2 = _read();
#test addition
my @BC = _add(@B1,@B2);
print "+:",_print(@BC);
# test substract
   @BC = _sub(@BC,@B2);
print "-:",_print(@BC);
#simplify the result
   @BC = simplify(@BC);

#test multiplication
   @BC = _mul(@B1,@B2);
print "*:",_print(@BC);
#test division
   @BC = _div(@BC,@B2);
print "/:",_print(@BC);
#simplify the result
   @BC = simplify(@BC);

sub _add {
    my $gn = $_[1]*$_[3];
    return(($_[0]*($gn/$_[1]))+($_[2]*($gn/$_[3])),$gn);
}

sub _sub {
    my $gn = $_[1]*$_[3];
    return(($_[0]*($gn/$_[1]))-($_[2]*($gn/$_[3])),$gn);
}

sub _mul {
    return($_[0]*$_[2],$_[1]*$_[3]);
}

sub _div {
    return($_[0]*$_[3],$_[1]*$_[2]);
}

sub _print {
    my @D = &simplify;
    my $c = 0;
    while(1){
        if($D[0]>=$D[1]){
            $D[0] -= $D[1];
            ++$c;
        }else{
            last;    
        }
    }
    if($c){
        return "$c+$D[0]/$D[1](".&fractial2number.")\n"; 
    }else{
        return "$D[0]/$D[1](".&fractial2number.")\n"; 
    }
}

sub _read {
    print "fractal number:";
    my $in = <STDIN>;
    if($in =~ /\//o){
       $in =~ /^(.+)\/(.+)$/o;
        return($1,$2);
    }else{
       return(number2fractial($in)); 
    }
}

sub number2fractial {
    $_[0] =~ /^(.+)\.(.+)$/o;
    my $d = $1;
    my $c = $2;
    my $u = $2;
       $u =~ s/./0/g;
       $u = "1".$u;
    return($c+($d*$u),"$u");
}

sub fractial2number {
    return($_[0]/$_[1]);
}

sub simplify {
    for($_ = $_[1];$_>=2;--$_){
        return($_[0]/$_,$_[1]/$_) if($_[0]%$_==0 && $_[1]%$_==0);
    }
    return($_[0],$_[1]);
}

This is the output from 1/2 and 1.25, at first add both then subtract from the result, multiply and then divide from the result:

fractal number:1/2  
fractal number:1.25 
+:1+3/4(1.75)       
-:1/2(0.5)          
*:5/8(0.625)        
/:1/2(0.5)

For a better result take a look at Perl high precision.

Perl reference vs. direct access vs. return Benchmark

This is a little Perl Script where I try to test what way is faster,  I test a normal reference(alias) in a sub vs. the direct access vs. normal access to a variable in a sub and then return the result, here is my Benchmark code:

use Benchmark qw(:all) ;
use strict;
# test variable
my $x = 0;
my $y = 0;
my $c = 0;
# run test
inc_ref(\$x) for(0..10);
inc_direct($y) for(0..10);
$c = inc_ret($c) for(0..10);
# print test
print "TEST:$x-$y-$c\n";
# run benchmark
cmpthese(-2, {
'ref'    => sub {inc_ref(\$x);},
'direct' => sub {inc_direct($y);},
'return' => sub {$c = inc_ret($c);},
});
 
# increment with reference
sub inc_ref {
    ++${$_[0]};
}
# increment with direct access
sub inc_direct {
    ++$_[0];
}
# increment with return
sub inc_ret{
    return(++$_[0]);
}

Our test result:

TEST:11-11-11                         
            Rate return    ref direct 
return 1976160/s     --   -11%   -36% 
ref    2216116/s    12%     --   -28% 
direct 3084046/s    56%    39%     --