perl+SQL

http://citforum.ru/database/mysql/intro/

Введение в MySQL (используя Perl DBI)


use DBI;

my $dsn = 'DBI:mysql:my_database:localhost';
my $db_user_name = 'admin';
my $db_password = 'secret';
my ($id, $password);
my $dbh = DBI->connect($dsn, $db_user_name, $db_password);

my $sth = $dbh->prepare(qq{select id, password from users where nickname = $input_nickname});
$sth->execute();

-обработка-

my (@matrix) = ();
while (my @ary = $sth->fetchrow_array())
{
    push(@matrix, [@ary]);  # [@ary] это ссылка
}
$sth->finish();



$dbh->disconnect();

perl: показ ошибок

12.12. Вывод сообщений об ошибках и предупреждений по аналогии со встроенными функциями
Вывод ошибок интерпретатора perl в браузер
Программирование::Perl::Основы - F.A.Q.

Для апача крайне желательно выставить LogLevel warn или даже notice

Теперь о перле.
Самый простой вариант

#!/usr/bin/perl
use CGI::Carp qw(fatalsToBrowser);

запуск perl скриптов

Основной вариант запуска - через mod_perl
Можно в основной конфиг:

AddHandler perl-script .pl
PerlResponseHandler ModPerl::Registry

Или в .htaccess, в cgi-bin:

Options +ExecCGI
SetHandler cgi-script


В основной каталог (httpdocs, htroot, www, public_html...)
AddHandler cgi-script .pl

Проверочный код:

#!/usr/local/bin/perl -w
print "Content-type: text/html\n\n";
print "It works!<br>\n";

Первая строка при выводе в браузер обязательна: она сообщает, что это страница.

Punycode

Библиотек для конвертирования в Punycode много. В общем случае оно называется IDN или IDNA, иногда Punycode.

Python
Встроенными средствами с 2.4:

>>> ru = "ДОМЕНЫ.РУ"
>>> u = unicode(ru, "koi8-r") # Из koi8 в unicode...
>>> u.encode("idna") #... и перекодируем
'xn--d1acufc5f.xn--p1ag'

Perl
Тут несколько библиотек, все работают по разному...
Net::IDN::Encode
URI::UTF8::Punycode
IDNA::Punycode (DEPRECATED)
Convert::RACE
Net::IDN::Nameprep
Net::LibIDN (бинды к libidn)

php
http://pear.speedpartner.de/,
http://fastserv.name.net/open_source/php/punycode/

C
idnkit, libidn

линки
http://s3blog.org/konvertacija-domena-v-zone-rf-v-punycode.html
http://www.rlnic.ru/technology/punycode.pl
http://www.koscheev.ru/articles/perl/?n=38

perl

Входные аргументы
$ARGV[0]

$# оператор получения максимального индекса массива
if ($#ARGV<0) ... //нет аргументов

Проверяем права

<br /> PHP<br /> <pre><?php function GetUsernameFromUid($uid) { if (function_exists('posix_getpwuid')) { $a = posix_getpwuid($uid); return $a['name']; } # This works on BSD but not with GNU elseif (strstr(php_uname('s'), 'BSD')) { exec('id -u ' . (int) $uid, $o, $r); if ($r == 0) return trim($o['0']); else return $uid; } elseif (is_readable('/etc/passwd')) { exec(sprintf('grep :%s: /etc/passwd | cut -d: -f1', (int) $uid), $o, $r); if ($r == 0) return trim($o['0']); else return $uid; } else return $uid; } echo "Read ID: ".posix_getuid()."\n"; echo "Effective ID: ".posix_geteuid()."\n"; //mkdir test; ls test; rmdir test; ?> </pre><br /> perl<br /> <br /> <br />

3 варианта подключения файла в перле

На примере сапы
my $sape_id = 'aaaaaa';
1) require sprintf('%s/%s/SAPE.pm', $ENV{'DOCUMENT_ROOT'}, $sape_id);
2) require "$ENV{DOCUMENT_ROOT}/${sape_id}/SAPE.pm";
3) "$ENV{DOCUMENT_ROOT}/aaaaaaa/SAPE.pm" =~ /^(.+)$/; require $1;

Как мне кажется, 2 метод оптимальный. Вопрос, как там со всякими null-byte уязвимостями.

Особенности подключения модулей и сообщений об ошибках

Переносили сайт.
Проблема возникла с TrustLink:

/var/www/site/htroot/ffffff at (eval 12) line 13.
{
{
        'ffffff';

        push @INC, "$ENV{DOCUMENT_ROOT}/$o->{TRUSTLINK_USER}";
->      eval("use TrustlinkClient;") or die $!;
        my $trustlink = new TrustlinkClient($o);
        undef($o);
#       use Data::Dumper;
#       print '<pre>',Dumper($trustlink),'</pre>';

        print $trustlink->build_links();
}

Права в порядке. Добавили перед евалом

warn join ("\n", @INC);

Вывод нормальный, аномалий нет, путь к нужному модулю есть.
Вставили вместо евала прямое подключение

require "$ENV{DOCUMENT_ROOT}/ffffff/TrustlinkClient.pm";

Оказалось, он не модуль не видит, а в модуле ошибка - нет библиотеки URI. Проблема была решена установкой libwww-perl
Так из-за абсолютно невменяемого показа ошибок диагностика заняла 3 часа.

perl: профилирование

Вариантов много.
perl -d:NYTProf script.pl
nytprofhtml && смотрим в браузере

perl-Class-Accessor-Named.noarch : Better profiling output for Class::Accessor
perl-Devel-Profiler.noarch : Perl profiler compatible with dprofpp
perl-Template-Timer.noarch : Rudimentary profiling for Template Toolkit
perl-Test-Timestamp.noarch : Create timestamp objects for testing or profiling
perl-Devel-NYTProf.x86_64 : Powerful fast feature-rich perl source code profiler
perl-Devel-SmallProf.noarch : Per-line Perl profiler
perl-Template-Timer.noarch : Rudimentary profiling for Template Toolkit

oprofile.x86_64 : System wide profiler

module trim

# Perl trim function to remove whitespace from the start and end of the string
sub trim($)
{
my $string = shift;
$string =~ s/^\s+//;
$string =~ s/\s+$//;
return $string;
}

sub ltrim($)
{
my $string = shift;
$string =~ s/^\s+//;
return $string;
}

sub rtrim($)
{
my $string = shift;
$string =~ s/\s+$//;
return $string;
}

parse liveinternet.ru

#!/usr/bin/perl

use IO::File;

$inputfn=(($ARGV[0] ne '')?$ARGV[0]:"hosts.txt");
print "Parsing file: $inputfn\n";

#GET "http://www.liveinternet.ru/stat/site.ru/index.html?period=month;total=yes" | grep -A 1 id_8 | tail -1 | perl -e '<>=~/\>(\d+)\</;print $1;print "\n";'

#counter end
$ce=(($ARGV[1] ne '')?$ARGV[1]:"0");
my $c = 0;

open(F, $inputfn) or die $!;

while ($a=<F>)
{
        $a = trim ($a);

        if ($a ne "")
        {

                $req='GET "http://www.liveinternet.ru/stat/';
                $req.=$a;
                $req.='/index.html?period=month;total=yes" | grep -A 2 id_8 | tail -1';
#print ($req);
                $str=`$req`;
                $str=~m/\>([\d.,]+)\0 && $c >= $ce);
}

close F;

# Perl trim function to remove whitespace from the start and end of the string
sub trim($)
{
        my $string = shift;
        $string =~ s/^\s+//;
        $string =~ s/\s+$//;
        return $string;
}

split access_log by months

#!/usr/bin/perl

my $in = @ARGV[0];
open (IN, $in);

my $f = '';

while (my $str = )
{
    $str =~ m#\[(\d{2})/(\w{3})/(\d{4}):.*]#;
    #print "$3$2 $str \n";
    my $cur = "$3$2";
    if ( $cur ne $f)
    {
        if ($f ne '') {close OUT;}

        $f = $cur;
        open (OUT, "> $f-$in");
        print "$f-$in\n";
    }

    print OUT $str;
}


close IN;
close OUT;
#return 0;
exit 0;

#in: parse.pl access_log
#out: 2011Feb-access_log, ...

sendsms

#!/usr/bin/perl
#use diagnostics;
#use strict;
#use Getopt::Std;

use vars qw/ %opt /;
use Getopt::Std;
use URI::Escape;

%group = {
admins => (
"7921xxxxxxx",
"123"
),
all => (
"987",
"654"
)
};

$login='login';
$pass='pass';
$gate='1cgw.streamsms.ru';
$from='web';

sub Send
{
# print @_;
my @list=@_;
foreach $list (@list)
{
$cmd="GET \"http://$gate/sendsms.php?user=$login&pwd=$pass&sadr=$from&dadr=$list&text=$msg\"";
# $out=$cmd;
# $out=`$cmd`;
if ($opt_v==1 || $opt_d==1) { print $cmd."\n";}
if ($opt_d==1) { next; }
$out=`$cmd`;
if ($opt_v==1) { print $out."\n";}
}
}

sub usage
{
print STDERR << "EOF"; usage: $0 [-h] [-v|-d] [-g group|-n number] text of sms -h :help -v : verbose -f : from -g : group (from code), mb admins -n : phone number, 11 digits (7921xxxxxxx), without + -d : dumb mode - only show EOF exit; } if ($#ARGV<1) { #exit ("see usage"); usage(); exit(); } @admin = ('7921xxxxxxx'); @admins = ('7921xxxxxxx','7921yyyyyyy'); @test = ('123','456'); getopts ('dhvf:g:n:') ;# or usage(); usage() if $opt_h; #$msg = join (" ", @ARGV); #print %opt; $msg = uri_escape(join (" ", @ARGV)); if (length($opt_f)>0)
{
$from=$opt_f;
}

if (length($opt_g)>0)
{
#Send($group{$opt_g}); #@admins);
Send(@admins);

}

if (length($opt_n)>0)
{
Send($opt_n);
}