Open Way | Systems | Distro | Shell | Desktop | Applications
Network | Development | Download | OfftopicКарта сайта
FreeNotesФорум POSIX.ru
На главную страницу

Tips от Madskull'a: Perl

Сергей Майков aka Madskull
http://www.mdsk.ru
2005.11.12

Установка локали в скриптеВ начало

Для использования текущей локали, достаточно
use locale; 

Если же нужна другая локаль, то можно сделать так


use locale; 
use POSIX qw(locale_h);
setlocale(LC_ALL,"ru_RU.KOI8-R");


Загрузка модулей из нестандартного местаВ начало

Программа находится в /path/to/bin
Модуль - в /path/to/lib
use FindBin qw($Bin);
use lib "$Bin/../lib";
use MyModule;


Декодирование символов вида %2A%20В начало

s/\%([0-9a-fA-F]{2})/chr(hex($1))/ge


Эмуляция try..catchВ начало

(Пример из "Camel book")

объявление

sub try(&$)
{
	my ($try,$catch) = @_;
	eval { &$try };
	if ( $@ ) {
		local $_ = $@;
		&$catch
	}
}

sub catch(&) { $_[0] }

использование

try {
	die "error";
}
catch {
	/error/ and print "Error!\n";
	print "Unknown error: $_\n"

};


Получение имени тома CD или DVD дискаВ начало

Может, есть и более "элегантные" решения, но не было времени искать.
(позже оказалось, что, например, команда file /dev/cdrom тоже покажет label)
#!/usr/bin/perl -w
eval {
	$ARGV[0] || die "Usage: cd-label <device>\n";
	open F,"<$ARGV[0]" or die $!."\n"; 
	seek(F,0x8028,0) or die $!."\n"; 
	read(F,$t,32) or die $!."\n"; 
};
if ($@) {
	print STDERR $@;
	exit 1;
}
$t=~s/\s+$//; 
print $t."\n"



Неочевидные фишки Perl'aВ начало

$a||=1 то же самое, что и $a=1 unless $a

получение размера массива: scalar(@a) или @a+0 ну или общеизвестное $#a+1

чтение списка файлов @files=<*.pl> или, при использовании подстановок @files=glob($filter)

Getopt::StdВ начало

getopts('a:b:c', \%opts);
my ($opt_a,$opt_b,$opt_c) = ("def-a","def-b", 0);
$opt_a = $opts{'a'} if defined $opts{'a'};
$opt_b = $opts{'b'} if defined $opts{'b'};
$opt_c = 1 if defined $opts{'c'};



Text::IconvВ начало

my $iconv = new Text::Iconv($fromenc, $toenc);
my $text2 = $iconv->convert($text1);


Кодировка ->транслитВ начало

( Ну не нравицца мне стандартный koi7 )
sub translit
{
	my $text = shift;
	$text =~ y/абвгдеёзийклмнопрстуфхъыьэ/abvgdeezijklmnoprstufh'y'e/;
	$text =~ y/АБВГДЕЁЗИЙКЛМНОПРСТУФХЪЫЬЭ/ABVGDEEZIJKLMNOPRSTUFH'Y'E/;
	my %mchars = ('ж'=>'zh','ц'=>'ts','ч'=>'ch','ш'=>'sh','щ'=>'sch','ю'=>'ju','я'=>'ja',
		'Ж'=>'Zh','Ц'=>'Ts','Ч'=>'Ch','Ш'=>'Sh','Щ'=>'Sch','Ю'=>'Ju','Я'=>'Ja');
	for my $c (keys %mchars) {
		$text =~ s/$c/$mchars{$c}/g;
	}
	return $text;
}



alarm: прерывание по времениВ начало

eval {
	$SIG{ALRM} = sub { die "alarm\n" };
	alarm 10;
	# ... code

};
if ( $@ eq "alarm\n" ) {
	print "время вышло!\n";
}


Ловим прерыванияВ начало

eval {
	$SIG{INT} = sub { die "int\n" };
	# ... code
};
if ( $@ eq "int\n" ) {
	print "^C pressed\n";
}


Пародия на wget - закачка с прогрессбаром (Net::FTP::dataconn,URI)В начало

#!/usr/bin/perl -w

use strict;
use URI;
use Net::FTP;
use FileHandle;

$|=1;
my $progress_length = 50;

unless ($ARGV[0]) {
	print "Usage: $0 url\n";
	exit 1;
}

my $uri = new URI($ARGV[0]);
die "error in url" unless $uri->scheme && $uri->scheme eq "ftp";

my ($dir,$file) = $uri->path =~ /(.*)\/(.*)/;
die "error in url: no file part" unless $file;

print "Connect to ".$uri->host." ... ";
my $ftp = new Net::FTP( $uri->host, Port=>$uri->port, Passive=>1, Debug => 0)
	or die "Cannot connect to $uri->host: $@";

$ftp->login($uri->user,$uri->password)
	or die "Cannot login ", $ftp->message;

$ftp->cwd($dir) || die("Cannot change working directory ", $ftp->message) if $dir;

print "Ok\nGet file ... \n";
my $size = $ftp->size($file);
die "File not found: ", $ftp->message unless defined $size;

$ftp->binary;
my $in = $ftp->retr($file) or die "Can't download file: ",$ftp->message;

my $out = new FileHandle(">$file") or die "Can't create local file: ", $!;
binmode $out;

my ($len,$buf)=(0,'');
while( $len < $size ) {
	$len += $in->read($buf,$size-$len) || last;
	print $out $buf;
	my $perc = int(100*$len/$size);
	my $done = int($progress_length*$perc/100);
	print "\r[".($done?"#"x$done:"").
		($progress_length-$done?"-"x($progress_length-$done):"").
		"] $perc\% $len bytes";
}
print "\n";
$out->close;
$ftp->quit;



Использование LWPВ начало

use LWP;
use HTTP::Cookies;

my $ua = LWP::UserAgent->new;
$ua->cookie_jar(HTTP::Cookies->new());
$ua->agent('Mozilla/4.0 (compatible; MSIE 6.0; X11; Linux i686; en) Opera 7.60');

my $Headers = new HTTP::Headers(
	'Referer' => 'http://some.host.ru/index.html',
	'Accept' => 'text/html, application/xml;q=0.9, application/xhtml+xml, 
image/png, image/jpeg, image/gif, image/x-xbitmap, */*;q=0.1',
	'Accept-Language' => 'ru',
	'Accept-Charset' => 'koi8-r, utf-8, utf-16, iso-8859-1;q=0.6, *;q=0.1',
	'Cookie' => 'sid=0; hotlog=1',
	'Cookie2' => '$Version=1',
	'Connection' => 'Keep-Alive, TE',
	'TE' => 'deflate, gzip, chunked, identity, trailers',
);	# выдергано из запросов Оперы

$ua->default_headers($Headers);

# регистрируемся
my $res = $ua->post('http://some.host.ru/log/in/',
		[ 'login' => $login, 'pass' => $passwd ] );
# если используется перенаправление !
$res = $ua->get('http://some.host.ru/'.$res->header("Location"));
die "FAIL!\n" unless ( $res->is_success );


# забираем нужное нам нечто
$ua->default_header(Referer=>"http://some.host.ru/things/index.html");
$res = $ua->get("http://some.host.ru/things/warez.zip");
die "FAIL!" unless $res->is_success;

# сохраняем
open F, ">warez.zip";
binmode F;
print F $res->content;
close F;

PRE: Использование Net::FTP
use Net::FTP;

$ftp = Net::FTP->new("ftp.narod.ru", Passive => 1, Debug => 1)
	or die "Cannot connect to ftp.narod.ru: $@";

$ftp->login( $login, $passwd )
	or die "Cannot login ", $ftp->message;

$ftp->cwd("/warez")
	or die "Cannot change working directory ", $ftp->message;

$ftp->put("index.html")
	or die "Cannot send file ", $ftp->message;

$ftp->quit;



Встроенные переменныеВ начало

$`строка, следующая за совпадением
$-число строк, оставшихся на странице
$!текущая ошибка
$`разделитель полей массивов при интерполировании
$#формат вывода чисел с плавающей точкой
$$идентификатор процесса Perl
$%текущая страница вывода
$&совпадение с шаблоном поиска
$(реальный идентификатор группы пользователей (real GID)
$)текущий идентификатор группы пользователей (effective GID)
$*совпадение с шаблоном поиска
$,разделитель полей вывода
$.текущий номер строки ввода
$/разделитель входных записей
$:маркер разбивки строки
$;разделитель индексов
$?статус последней системной операции
$@ошибка выполнения функции eval
$[базовый индекс массивов
$\разделитель выходных записей
$]версия Perl
$^текущий формат колонтитула страницы
$^Aнакопитель команды write
$^Dтекущие флаги отладки
$^Eинформация об ошибке, специфичная для операционной системы
$^Fмаксимальное количество дескрипторов файлов
$^Hфлаги проверки синтаксиса
$^Iрасширение файлов для редактирования `по месту`
$^Lсимвол прогона страницы
$^Mбуфер памяти `на крайний случай`
$^Oимя операционной системы
$^Pподдержка отладки
$^Rрезультат вычисления утверждения в теле шаблона
$^Sсостояние интерпретатора
$^Tвремя запуска сценария на выполнение
$^Wрежим вывода предупреждающих сообщений
$^Xимя программы-интерпретатора
$_аргумент по умолчанию
$`строка, следующая перед совпадением
$|управление буфером вывода
$~имя текущего формата отчетов
$+фрагмент совпадения
$<реальный идентификатор пользователя (Real User ID)
$=текущий размер страницы
$>текущий идентификатор пользователя (Effective User ID)
$Oимя программы
$ARGVимя входного файла
$nnnn-й фрагмент совпадения
%ENVпеременные окружения
%INCподключаемые файлы
%SIGобработчики ситуаций
@_аргументы, переданные подпрограмме
@ARGVаргументы, переданные в командной строке
@INCпути поиска подключаемых файлов


Отключение буферизацииВ начало

В частности, print без "\n" выводит текст сразу.
$| = 1;	                      # для текущего потока вывода
autoflush STDOUT 1;           # только для STDOUT

$f = new FileHandle(">file");
$f->autoflush(1);             # только для file


Сортировка хэша по значениямВ начало

print "$_ = $h{$_}\n" for( sort { $h{$a} > $h{$b} } keys %h);


Использование HTML::LinkExtorВ начало

#!/usr/bin/perl -w

require HTML::LinkExtor;

my ($file) = @ARGV;

$p = HTML::LinkExtor->new(\&callback);
$p->parse_file($file);

sub callback {
    my($tag,%attr) = @_;
    print "$attr{href}\n" if $tag eq 'a';
}


Дата и время Time::localtimeВ начало

use Time::localtime;

sprintf("%02d.%02d.%02d %02d:%02d:%02d",
	localtime->mday(), 
	localtime->mon()+1,
	localtime->year()-100,
	localtime->hour(),
	localtime->min(),
	localtime->sec()
);


Чтение файла в массивВ начало

use FileHandle;

my @text = (new FileHandle("<file") or die "$!")->readlines();


Использование BenchmarkВ начало

use Benchmark;
timethese(1000000,
	{
		test1 => '...code...',
		test2 => '...code...',
	}
);


Использование Data::DumperВ начало

use Data::Dumper;

%hash = (...);
@array = (...);

print Dumper(\%hash);
print Dumper(\@arra);

Хочешь раскрутить сайт бесплатно:
раскрутка сайта. . Сопровождение беспроводной сети - типовой договор на обслуживание компьютеров, прайс-лист в Москве. . Предлагается датчик угла поворота и инженерно-консультационные услуги.