Язык программирования Perl

http://search.cpan.org/

[root@lb2 ~]# perl -MCPAN -e shell

cpan[1]> install Encode::IMAPUTF7

• Отключение буферизации вывода
• Чтение данных с STDIN
• Регулярный разбор полей строки

# cat readstdin.pl

#!/usr/bin/perl

$|=1;

while(<>) {
        print $_;
        if (/^(allow|deny) ([^ ]+) ([^ ]+) ([^ ]+) (.*$)/) {
                $act=$1;
                $proto=$2;
                $src=$3;$dst=$4;$port=$5;
                $count++;
                print "ipfw -q add $act $proto from $src to $dst $port\n";
        }
}

• Усиление контроля синтаксиса
• Обработка аргументов
• Использование внешних утилит
• Регулярный разбор полей строковой переменной

# cat show_cdp_neighbors.pl

#!/usr/bin/perl

use strict;
use warnings;

my ($ip) = @ARGV;

unless($ip) {
  die "Need ip\n";
}

my $sw=`snmpget -On -m ALL -c public -v2c $ip sysName.0 2>/dev/null`;

print "neibors for switch: $sw\n";

foreach my $i (`snmpwalk -On -v2c -c public -m ALL $ip .1.3.6.1.4.1.9.9.23.1.2.1.1.6 2>/dev/null`) {
                $i=~/.*STRING: (.*)/;
                print "$1\n";
}

• Использование MySQL
• autoincrement
• transaction
• error handling

CREATE TABLE
    table1 (
        a INT NOT NULL AUTO_INCREMENT,
        b INT NOT NULL,
        PRIMARY KEY(a)
    );
CREATE TABLE
    table2 (
        b INT NOT NULL,
        a INT NOT NULL,
        PRIMARY KEY(b)
    );
CREATE TABLE
    table3 (
        b INT NOT NULL,
        a INT NOT NULL
    );

# cat example3.pl

#!/usr/bin/perl

use DBI;

print "Start\n";

my $dsn = 'DBI:mysql:test:127.0.0.1:3306';
my $db_user_name = 'test';
my $db_password = 'test';

printf "Connect to test\n";

my %attr = (AutoCommit=>0,RaiseError=>1,HandleError => \&DBerror);
my $dbh = DBI->connect($dsn, $db_user_name, $db_password, \%attr);

my $sth = $dbh->prepare(qq{SET NAMES 'utf8'});
$sth->execute() or print "Cannot execute: " . $sth->errstr();

printf "Loop\n";
MAINLOOP:
for (my $c = 10; $c >= 1; $c--) {

        my $b = int(rand(10));


        $sth = $dbh->prepare(qq{insert into table1 (b) values ($b)});
        #print $sth->{Statement};
        $sth->execute() or next MAINLOOP;

        $sth = $dbh->prepare(qq{select LAST_INSERT_ID()});
        $sth->execute() or next MAINLOOP;
        my ($a)=$sth->fetchrow_array();

        print "a = $a; b = $b\n";

        $sth = $dbh->prepare(qq{insert into table2 (b, a) values ($b, $a)});
        $sth->execute() or next MAINLOOP;

        $sth = $dbh->prepare(qq{insert into table3 (a, b) values ($a, $b)});
        $sth->execute() or next MAINLOOP;

        $dbh->commit() or next;
}

$sth->finish();
$dbh->disconnect();

exit 0;

sub DBerror(){
    my $err = shift;
    print "ROLLBACK $err\n";
    $dbh->rollback();
}

• Использование UTF8
• Работа с XML форматом (Get value of elements using XML::DOM)

# cat postgraduate.xml

<?xml version="1.0" encoding="UTF-8"?>
<service>
  <postgraduates>
    <postgraduate uuid="f601dc22-8572-11e2-af21-00270e0c47d1" pcn="" lastname="Аббаси" firstname="Домиан" middlename="">
    <speciality uuid="a15a5280-8572-11e2-a896-00270e0c47d1" code="05.02.05" name="Роботы, мехатроника и робототехнические системы"/>
    <tutor uuid="a334e516-8572-11e2-a6e3-00270e0c47d1" lastname="Медведев" firstname="Владимир" middlename="Степанович"/>
    <dismissal>
      <item dismissal_date="2001-12-25" cause_uuid="26e23a26-c0e4-11df-96e9-003048c6b34e" cause="окончание срока обучения" order_num="" order_date=""/>
    </dismissal>
  </postgraduate>
  <postgraduate uuid="ba68ada2-8573-11e2-a21a-00270e0c47d1" pcn="17" lastname="Бородулин" firstname="Денис" middlename="Сергеевич">
    <speciality uuid="a17a23d0-8572-11e2-8061-00270e0c47d1" code="05.11.03" name="Приборы навигации"/>
    <tutor uuid="5667f692-9908-4573-adde-78bef03ab3d7" lastname="Коновалов" firstname="Сергей" middlename="Феодосьевич"/>
    <dismissal>
      <item dismissal_date="2013-04-15" cause_uuid="26e22ab7-c0e4-11df-96e9-003048c6b34e" cause="по аттестации" order_num="02.01-04/21" order_date="2013-04-22"/>
    </dismissal>
   </postgraduate>
  </postgraduates>
</service>

# cat xml2txt.pl

#!/usr/bin/perl -w

use XML::DOM;
use strict;
use utf8;

binmode(STDOUT,':utf8');

my $parser = new XML::DOM::Parser;
my $doc = $parser->parsefile ('postgraduate.xml');
my @nodes =$doc->getElementsByTagName("postgraduate");

foreach my $node (@nodes) {

#    print $node->toString;
    
    my $uuid = $node->getAttributeNode ("uuid")->getValue;
    my $lastname = $node->getAttributeNode ("lastname")->getValue;
    my $firstname = $node->getAttributeNode ("firstname")->getValue;
    my $middlename = $node->getAttributeNode ("middlename")->getValue;
    print "$uuid,$lastname,$firstname,$middlename\n";
}

• CommuniGate Pro Perl Interface
• Библиотека скриптов для CommuniGate Pro (бесплатно)

# wget https://www.communigate.ru/CGPerl/CLI.pm

# mv CLI.pm /etc/perl/

# cat addcgpuser.pl

#!/usr/bin/perl

use strict;
use CLI;

my ($AccountName,$RealName,$Password) = @ARGV;

my $cli = new CGP::CLI( { PeerAddr => '127.0.0.1',
                            PeerPort => 106,
                            login    => 'postmaster',
                            password => 'Pa$$w0rd'
                        } ) 
  || die "Can't login to CGPro: ".$CGP::ERR_STRING."\n";


my $UserData;
  @$UserData{'RealName'}=$RealName;
  @$UserData{'Password'}=$Password;

$cli->CreateAccount(accountName => $AccountName,
                            settings => $UserData) 
  || die "Can't create account: ".$CGP::ERR_STRING."\n";

$cli->Logout;

exit;

mail# ./addcgpuser.pl user3 'Сидор Сидорович Сидоров' password3

• Perl CGI
• http://....hello.pl?name=ivanov

$ cat hello.pl

#!/usr/bin/perl

use strict;
use CGI;

my $q=new CGI();
my $name=$q->param('name');
print qq|
<html>
<body>
<h1>Hello $name</h1>
</body>
</html>
|;

• Random Password Generator in Perl
• Транслит