Perl sort example

Sorting in Perl with user defined subroutines.

https://github.com/64board/Perl/blob/main/sort.pl

Perl Getopt::Std example

Example of using Getopt::Std module.

https://github.com/64board/Perl/blob/main/get_opt.pl

Perl Date::Manip::Date business day

 #!/usr/bin/perl

# Creates /etc/cron.d file entries, one per month,
# for a program that should run on the previous
# day to last business day of the month.
# Uses Date::Manip::Date module, https://metacpan.org/dist/Date-Manip/view/lib/Date/Manip/Date.pod.
# 64board@gmail.com
# 2021-08-31
 
use strict;
use warnings;

use Date::Manip::Date;

sub cron_entry {

    my ($date) = @_;

    return $date->printf("30 19 %d %m %a\troot\t/opt/balmo_id/run.sh");
}

##MAIN##

my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);

my $date = new Date::Manip::Date;

foreach my $month (@months) {

    print "Month: $month\n";

    # Get the last day of the month of current year.
    $date->parse("last day in $month");

    print 'Last day of the month: ', $date->printf('%Y-%m-%d, %a'), "\n";

    # Don't check time for business day.
    my $checktime = 0;

    my $offset = 1;
    # Case of last day of the month is not a business day.
    if (!$date->is_business_day($checktime)) {
    $offset = 2;
    }

    # The pevious day to last business day of the month.
    $date->prev_business_day($offset, $checktime);

    print 'Previous business day: ', $date->printf('%Y-%m-%d, %a'), "\n";

    # The CRON entry, use CRON: label to filter the cron entries
    # from the output.
    print "CRON: ", cron_entry($date), "\n";
}

__END__

Capturing with Perl and REGEX two numbers on a line, one of them is optional

 #!/usr/bin/perl

use strict;
use warnings;

sub get_long_short {
   my ($number, $spaces1, $spaces2) = @_;
   my ($long, $short) = ('', '');

   if (length($spaces1) > length($spaces2))
   {
      $short = $number;
   } else {
      $long = $number;
   }

   return ($long, $short);
}

while (<DATA>) {

   chomp();

   if (my ($b1, $n1, $n2, $b2, $s) = /
      ^(\s*)            # First spaces ($b1)
      ([\d,.]+)         # First number always exists ($n1)
      (?:               # Don't want to capture spaces
      \s+               # in front
      ([\d,.]+)         # Second number ($n2)
      )?                # Second number is optional
      (\s+)             # Space always exists ($b2)
      (\w{2,3})$        # Two or three letters symbol ($s)
      /x)
   {
      my ($long, $short);

      if (defined($n2)) {
         $long = $n1;
         $short = $n2;
      } else {
         ($long, $short) = get_long_short($n1, $b1, $b2);
      }

      $long =~ s/,//g;
      $short =~ s/,//g;

      print("$long|$short|$s\n");

   } else {
      print("NOT MATCHED: $_\n");
   }
}

__END__
long short symbol
12 3  NG
1,234 1,222 CL
1,333       PL
123.4 9,088     HNG
123.4 9,088     BBBB
       90.65 HO
   1   RB
    2  RB
     3 RB
4      RB
  100,000.00     CL
  CL

Sending Mail in Perl

Using MIME::Lite module

You could write your own email client using MIME:Lite perl module. You can download this module from MIME-Lite-3.01.tar.gz and install it on your either machine Windows or Linux/Unix. To install it follow the following simple steps:

$tar xvfz MIME-Lite-3.01.tar.gz
$cd MIME-Lite-3.01
$perl Makefile.PL
$make
$make install

That's it and you will have MIME::Lite module installed on your machine. Now you are ready to send your email with simple scripts explained below.

SENDING A PLAIN MESSAGE

Now following is a script which will take care of sending email to the given email ID:

#!/usr/bin/perl
use MIME::Lite;
 
$to = 'abcd@gmail.com';
$cc = 'efgh@mail.com';
$from = 'webmaster@yourdomain.com';
$subject = 'Test Email';
$message = 'This is test email sent by Perl Script';

$msg = MIME::Lite->new(
                 From     => $from,
                 To       => $to,
                 Cc       => $cc,
                 Subject  => $subject,
                 Data     => $message
                 );
                 
$msg->send;
print "Email Sent Successfully\n";

SENDING AN HTML MESSAGE

If you want to send HTML formatted email using sendmail then you simply need to add Content-type: text/html\n in the header part of the email. Following is the script which will take care of sending HTML formatted email:

#!/usr/bin/perl
use MIME::Lite;
 
$to = 'abcd@gmail.com';
$cc = 'efgh@mail.com';
$from = 'webmaster@yourdomain.com';
$subject = 'Test Email';
$message = '<h1>This is test email sent by Perl Script</h1>';

$msg = MIME::Lite->new(
                 From     => $from,
                 To       => $to,
                 Cc       => $cc,
                 Subject  => $subject,
                 Data     => $message
                 );
                 
$msg->attr("content-type" => "text/html");         
$msg->send;
print "Email Sent Successfully\n";

SENDING AN ATTACHEMENT

If you want to send an attachement then following script serve the purpose:

#!/usr/bin/perl
use MIME::Lite;
 
$to = 'abcd@gmail.com';
$cc = 'efgh@mail.com';
$from = 'webmaster@yourdomain.com';
$subject = 'Test Email';
$message = 'This is test email sent by Perl Script';

$msg = MIME::Lite->new(
                 From     => $from,
                 To       => $to,
                 Cc       => $cc,
                 Subject  => $subject,
                 Type     => 'multipart/mixed'
                 );
                 
# Add your text message.
$msg->attach(Type         => 'text',
             Data         => $message
            );
            
# Specify your file as attachement.
$msg->attach(Type        => 'image/gif',
             Path        => '/tmp/logo.gif',
             Filename    => 'logo.gif',
             Disposition => 'attachment'
            );       
$msg->send;
print "Email Sent Successfully\n";

You can attache as many as files you like in your email using attach() method.

Using SMTP Server

If your machine is not running an email server then you can use any other email server available at remote location. But to use any other email server you will need to have an id, its password, URL etc. Once you have all the required information, you simple need to provide that information in send()method as follows:

$msg->send('smtp', "smtp.myisp.net", AuthUser=>"id", AuthPass=>"password" );

You can contact your email server administrator to have above used information and if a user id and password is not already available then your administrator can create it in minutes.

Taken from: http://www.tutorialspoint.com/perl/perl_sending_email.htm

MP3 tagging with Perl

#!/usr/bin/perl

use strict;
use warnings;

use MP3::Tag;
use File::Basename;

my $Directory = ".";

while (<$Directory/*.mp3>) {
my ($FileName) = basename($_, '.mp3');

my $Mp3 = MP3::Tag->new($_);

$Mp3->title_set($FileName);
$Mp3->artist_set('Artist');
$Mp3->album_set('Album');
$Mp3->year_set('2012');

$Mp3->update_tags();

print "Filename: $_\n";
print "Artist: " . $Mp3->artist . "\n";
print "Title: " . $Mp3->title . "\n";
print "Album: " . $Mp3->album . "\n";
print "Year: " . $Mp3->year . "\n";
print "Genre: " . $Mp3->genre . "\n";

$Mp3->close();
}

__END__

List lines in file A but not in file B

I found this interesting scripts' page: http://tkhanson.net/misc/ and I think that I got an alternative to the anb script:

#!/usr/bin/perl

use strict;

use warnings;

sub usage {

        print "$0: filea fileb\n";

        exit -1;

}

usage unless scalar @ARGV == 2;

my $a = shift @ARGV;

my $b = shift @ARGV;

open A, "<$a" or die "can't open $a: $!\n";

open B, "<$b" or die "can't open $b: $!\n";

my %bl;

$bl{$_}++ for (<B>);

for (<A>) {print "$_" unless $bl{$_}};

__END__

Or using map for the last lines:

my %bl = map {$_ => 1 } (<B>);

map {print "$_" unless $bl{$_}} (<A>);

TIMTOWTDI

Date formatting in Perl

use Date::Format;
my $Time = time2str("%D", time());

Give something like 07/20/11

Package libtimedate-perl (in hardy, Ubuntu 8.04.3 LTS)

dpkg -S Date::Format

Sending a text file in the body of an email using Perl

In Perl there is a package called Mail::Sendmail that could be used to send a simple text message.

The package for the module is libtimedate-perl (in hardy, Ubuntu 8.04.3 LTS)

dpkg -S Mail::Sendmail

#!/usr/bin/perl

use strict;
use warnings;

use Mail::Sendmail;

# Read the file into a string to put it into the mail hash variable
open FH, 'file.txt' or
        die "Error reading file.txt file: $!\n";
my @Lines = ;
chomp @Lines;
close FH;
my $Lines = join "\n", @Lines;

my $Recipients = 'somebody@mail.example';

my $Subject = 'Testing mail in Perl';

my %mail = (
        To => $Recipients,
        From => 'testing@mail.example',
        Subject => $Subject,
        Message => $Lines
);

$mail{Smtp} = 'mail.example';

if (sendmail %mail) {
        print "Mail sent OK.\n"
} else {
        print "Error sending mail: $Mail::Sendmail::error \n"
}

print "\n\$Mail::Sendmail::log says:\n", $Mail::Sendmail::log;

__END__

Using back references in SED

Today I have several CSV files, everyone with a header at the first line and a date at the first fields with the format mm/dd/yyyy. It was necessary to change that field into the format yyyy-mm-dd.

Here there is a Perl solution and also a SED one:

#!/usr/bin/perl
use strict;
use warnings;
while (<>) {
        chomp;
        if (/^[^0-9]/) {
                print "$_\n";
                next;
        }
        my @Fields = split /,/, $_, 2;
        my ($Month, $Day, $Year) = split /\//, $Fields[0];
        print "$Year-$Month-$Day, $Fields[1]\n";
}
__END__

sed -i.bak 's/^\([0-9]\+\)\/\([0-9]\+\)\/\([0-9]\+\)/\3-\1-\2/' *.csv

Yesterday on my way home I realized that the Perl script was horrible, a one-liner should be OK, like the one below:

perl -i.bak -pe 's!(\d+)/(\d+)/(\d+)!\3-\1-\2!' *.csv

Get public advisories from the National Hurricane Center

#!/usr/bin/perl
# Download the public advisory from National Hurricane Center


use strict;
use warnings;


use Net::FTP;


my $FtpServer = 'ftp.nhc.noaa.gov';
my $RemoteDir = '/pub/products/nhc/public';
my $LocalFileName = '/home/janeiros/chk/txt/nhc.txt';


# Get the modification time of the local file
my $LocalFileMDTM = (stat($LocalFileName))[9];


my $Ftp = Net::FTP->new($FtpServer, Passive => 1, Debug => 0)
        or die "Couldn't no connect to $FtpServer: $!\n";


$Ftp->login('anonymous', 'jesus.aneiros@gmail.com')
        or die "Couldn't logon to $FtpServer: $!\n";


$Ftp->cwd($RemoteDir);


$Ftp->ascii();


# Get the file name of the last advisory
my $RemoteFileName = ($Ftp->ls())[-1];


# Get the last modification time for the remote file
my $RemoteFileMDTM = $Ftp->mdtm($RemoteFileName);


# Get the file only if it is older than the local
if (!defined($LocalFileMDTM) || $RemoteFileMDTM > $LocalFileMDTM) {
        $Ftp->get($RemoteFileName, $LocalFileName);
}


$Ftp->quit;


__END__

Perl, REGEX, modifiers and arrays

Suppose you have a file like this:

 1* 2* 3 4 5 6

10 20 30* 40 50* 60

100 200 300 400* 500 600

1000 2000* 3000 4000 5000* 6000*

You need to extract the group of numbers per line that have a * associated, the result should be like this:

1 2

30 50

400

2000 5000 6000

Could you find a language that you obtain the same result with less lines of code than Perl?

#!/usr/bin/perl

use strict;

use warnings;

while (<>) {

chomp;

my @Data = /(\d+)\*/g;

print "@Data\n";

}

__END__

You can do it even with a one-liner:

janeiros@harlie:/media/disk$ perl -ne '@Data = /(\d+)\*/g; print "@Data\n"' data.txt

1 2

30 50

400

2000 5000 6000

From this example:

- The context, Perl assigning is sensible to the left part of the assignment sentence.

- The modifiers for the REGEXes, like the g in this case.

- The grouping for the extraction, the parentheses.

--

J. E. Aneiros

GNU/Linux User #190716 en http://counter.li.org

perl -e '$_=pack(c5,0105,0107,0123,0132,(1<<3)+2);y[A-Z][N-ZA-M];print;'

PK fingerprint: 5179 917E 5B34 F073 E11A  AFB3 4CB3 5301 4A80 F674

Counting lines in a file (61960627 lines)

sed -n '$=' file.txt

real    1m9.237s
user    1m8.602s
sys     0m0.631s

perl -ne 'END { print $NR }' file.txt

real    0m13.876s
user    0m13.245s
sys     0m0.630s

awk 'END { print NR }' file.txt

real    0m8.866s
user    0m8.257s
sys     0m0.608s

wc -l file.txt

real    0m2.550s
user    0m1.677s
sys     0m0.873s

wc file.txt

real    3m4.875s
user    3m3.970s
sys     0m0.895s

Padding a number to the right with zeros in Perl

#!/usr/bin/perl

use strict;

use warnings;

while (<>) {

chomp;

if (/^[a-zA-Z]/) {

print "$_\n";

next;

}

my ($Date, $Time, $Price, $Volume, $Index) =

split /,/;

$Time = sprintf("%0*d", 6, $Time);

print "$Date,$Time,$Price,$Volume,$Index\n";

}

__END_

MSSQL Perl Ubuntu

Ok what I need to do is probably setup a connection using UnixODBC ....
Then i can use that connection to connect to the MS SQL Server .....
which has ODBC compatibility mode enabled ......

1) Install the two packages "odbcinst1" and "libct1" with your
favourite package manager.  Now you have installed UnixODBC and
FreeTDS, respectively.

2) You have to tell FreeTDS about the MS SQL Server it should connect
to: Edit /etc/freetds/freetds.conf (with your favourite editor) and go
to the bottom of the file and copy/modify one of the entries names
MyServer to get something like this:

# Business Data
[BData]
host = 192.168.1.10
port = 1433
tds version = 8.0

where the name in square brackets, "BData", is something you have to
tell ODBC about later on, the "host" line is the DNS name or the IP
number (which is what I used above) of the box running MS SQL Server,
"port" is default for MS SQL Server 1433 and shouldn't have to be
changed unless you have done something funky on your MS SQL Server
installation, and for "tds version" 8.0 corresponds to SQL Server
2000.  (See http://www.freetds.org/userguide/tdshistory.htm for more
on versions.)

If you have more that one server you can add another block.

3) Tell UnixODBC where to find the FreeTDS driver and give it a name:
If /etc/odbcinst.ini does not include a block named "FreeTDS" copy the
content of /usr/share/doc/libct1/examples/odbcinst.ini to
/etc/odbcinst.ini to let UnixODBC know about the FreeTDS driver.
/etc/odbcinst.ini should now look something like this:

[FreeTDS]
Description     = FreeTDS 0.61-5 Deb
Driver          = /usr/lib/odbc/libtdsodbc.so
Setup           = /usr/lib/odbc/libtdsS.so
FileUsage       = 1
CPTimeout       = 5
CPReuse         = 5

where "FreeTDS" is the driver name.  

In this file you can also define ODBC drivers for MySQL, generic ODBC,
etc.

4) Make a named ODBC definition, with a specified FreeTDS database:
Edit /etc/odbc.ini and add a block looking something like this:

[BDataTDS]
Description     = Not That Important Data Server, FreeTDS connection
Driver          = FreeTDS
Servername      = BData
Database        = BigApplicationDB

where "BDataTDS" is the ODBC name to give to your application on the
Ubuntu box (e.g. Open Office), "Description" is just that, "Driver" is
the name defined in /etc/odbcinst.ini (in step 3), "Servername" is the name
defined in /etc/freetds/freetds.conf (in step 2), and "Database" is
the database you want to connect to on the MS SQL Server.

If you want to connect to more than one database, add another block
here.  If it is on the same MS SQL Server you use the same
"Servername", if it is a different one, you have to add another block
in step 2.

5) Try connection to the database, using the the unixODBC tool isql:

isql -v BDataTDS  

Look at http://www.freetds.org/userguide/ for more in depth help!

Taken from https://lists.ubuntu.com/archives/ubuntu-users/2005-May/033937.html

UDP server in Perl

#!/usr/bin/perl

use strict;

use warnings;

use IO::Socket::INET;

use IO::Handle;

if ($#ARGV <>

die "Argument should be an integer port number\n";

} elsif ($ARGV[0] =~ /\D+/) {

die "Argument should be an integer port number\n";

}

my $Port = $ARGV[0];

my $MySocket = new IO::Socket::INET->new(

LocalPort => $Port,

Proto => 'udp'

) or die "Error opening UDP port $Port $!\n";

print "\nListening on UDP port $Port ...\n\n";

my $MsgText;

open(FILE, ">>udpserver.txt") or die "Error opening udpserver.txt file $!\n";

FILE->autoflush(1);

$MySocket->autoflush();

my $count = 1;

while ($MySocket->recv($MsgText, 4096)) {

print "$count <$MsgText>\n";

print FILE "$count <$MsgText>\n";

$count++;

}

close(FILE);

__END__