$| = 1;

print "Content-type: text/html\n\n";

# WebWho+ programmed for Cyberstrider Ltd 
# By Tony Greenwood (TonyG  tony@worden.co.uk)
# 11th January 2002	
# Please mention www.webwho.co.uk somewhere

# A coder can spot his code no matter how much it is hacked 
# I spot my code all over the place and thats great. But not when 
# you put your name next to it when all you did was change
# the way it looks...If you want to be a coder then start by playing fair OK :)
### SETUP ###
# Presuming the first line showing the path to Perl is correct then
# WebWho will run  straight from the box. However you may
# want to change the look and feel as well as the domain
# searches and other neat stuff
my $submit_form="<INPUT STYLE='background-color:#FFB709' TYPE='submit' NAME='Check' value='Check it!'>";
#my $submit_form="<INPUT TYPE='image' src='/gfx/submit.gif' border=0 align='absmiddle'>";
##### TABLES
# table sizes
my $tw='420';		# Actual Table width
my $t1='250';		# Domain name cell
my $t2='80';		# Result cell
my $t3='90';		# Extra info cell
my $border=1;		# Table border, This is my sexy border and not the crappy table border
# table colors

my $webwhobar="#21299C"; 	# WebWho bar
my $input_area="#63adde";		# Type in the domain
my $list_names="#FFB709";		# Domain, result, Info
my $extras="#FFB709";		# Available or Check action
my $available="#63adde";		# row of info if available
my $unavailable="#1f5ca1";		# Row of info if not available
my $errorbox="red";		# server down or not responding row
my $details="#63adde";		# Info returned on a single whois
#### PAGE
# text colors
my $font=" size=2 face=\"Verdana, Arial,Helvetica, sans-serif\""; 	# Whenever you use $font :)
my $links="white";						# Body default ,Also hlink, vlink
my $text="black";						# Body default
my $webwhobart="white"; 		# WebWho bar
my $input_areat="black";		# Type in the domain
my $list_namest="black";		# Domain, result, Info
my $errorboxt="white";		# server down or not responding row
my $detailst="black";		# Info returned on a single whois
# page
my $background="white";					# page background
# messages
my $alltext="All";						# In drop down list to check for all
my $whatnext="<font color='black' $font>Available</font>";		# TLD is Available
my $taken="<font color='white' $font>Taken</font>";		# TLD is Taken
my $details1="<font color='black' $font><b>Details</b></font>";	# See detailed lookup
my $details2="<font color='black' $font><b>Check</b></font>";	# Same as to check if result is true
##### TLDS ######
# There are 3 elements to each TLD seperated by a comma.
# (1) The TLD to search for
# (2) The Database to search in
# (3) The text to search for if No match ie Is available
# You can add or take away tlds but make sure numbers in the
# angle brackes run from 0 to whatever
my @tld;
$tld[0]="co.uk,whois.nic.uk,No match";
$tld[1]="org.uk,whois.nic.uk,No match";
$tld[2]="me.uk,whois.nic.uk,No match";
$tld[3]="net.uk,whois.nic.uk,No match";
$tld[4]="ltd.uk,whois.nic.uk,No match";
$tld[5]="plc.uk,whois.nic.uk,No match";
$tld[6]="com,whois.crsnic.net,No match";
$tld[7]="net,whois.crsnic.net,No match";
$tld[8]="org,whois.publicinterestregistry.net,NOT FOUND";
$tld[9]="edu,whois.crsnic.net,No match";
$tld[10]="eu.com,whois.centralnic.com,No match";
$tld[11]="gb.com,whois.centralnic.com,No match";
$tld[12]="gb.net,whois.centralnic.com,No match";
$tld[13]="uk.com,whois.centralnic.com,No match";
$tld[14]="uk.net,whois.centralnic.com,No match";
$tld[15]="us.com,whois.centralnic.com,No match";
$tld[16]="info,whois.afilias.net,NOT FOUND";
$tld[17]="biz,whois.neulevel.biz,Not found:";
my $me = "webwho.cgi";	# Change this if you change the name of the script 
my $timeout=12;		# Seconds to check WHOIS. More seconds gives more chance


#use diagnostics;
#use strict;
#use CGI::Carp qw(fatalsToBrowser);
use CGI qw(:standard);
use IO::Socket;

# Variables used throughout the script
my ($i,$output,$what,$lupe,$timeblunder);
my @splitz;
my @result;
my @isit;
my @extras;
my $all=1;
my $more=0;

my $query=new CGI;
my %stuff = map {$_, $query->param($_)} $query->param();
if (defined $stuff{'command'})
if (!defined $stuff{'type'} or $stuff{'type'} eq ""){$stuff{'type'}=$alltext;}
$stuff{'type'} =~ tr/A-Z/a-z/;
foreach $i (@tld)
	if($stuff{'type'} eq $splitz[0]){$all=0;}
if ($all){$stuff{'type'}=$alltext;}



if ($stuff{'command'} eq "")
if (length($stuff{'command'})<3)
	{&fatal_error("Sorry wrong amount of characters");} 
if (! $all)
if ($all)
&fatal_error("Wierd? Ya really shouldn't have made it to here :(");

sub cleanup()
	$_[0] =~ tr/A-Z/a-z/;		
	$_[0] =~ s/http\:\/\///gi;	
	$_[0] =~ s/www\.//gi;		
	$_[0] =~ s/[^a-z0-9\-]//g;	
	$_[0] =~ s/^\-+//;		
	$_[0] =~ s/\-+$//g;		
	$_[0] =~ s/\s//g;		
	return $_[0];

sub domainchk()

	foreach $i (@tld)
		my $this=$_[0];
		my $that=$_[1];
		my @splitx=split(/,/,$i);
		if ($splitx[0] eq $that)
        				local $SIG{ALRM} = sub { die "alarm\n" };    
        				alarm ($timeout);
				$what  = IO::Socket::INET->new("$splitx[1]:43") or return ("$splitx[1] Server not responding");
				print $what "$this.$that\n";
				close $what;
				alarm (0);
			if ($@ eq "alarm\n") 
				return ("$splitx[1] Server Timed Out")
    				elsif ($@)
				return ("$splitx[1] Server Unexplained Error")

			# We know we got a valid return and no problems at this point
			my $whatis="$this.$that is Unavailable";
			foreach $i (@result) 
                			if ($i =~ /Whois Server: whois./ and $more)
					my $ckl=$i;
					$ckl=~s/Whois Server: //;
					$ckl =~ s/\s+//;
					my $added="";
        						local $SIG{ALRM} = sub { die "timed\n" };    
        						alarm ($timeout);
						$what  = IO::Socket::INET->new("$ckl:43") or $added="<b>($ckl) Server is not responding</b>";
						print $what "$this.$that\n";
						close $what;
						alarm (0);
					if ($@ eq "timed\n") 
						$added="$ckl Server Timed Out";
                			if ($i =~ /$splitx[2]/ig){$whatis="$this.$that is Available";}
			return $whatis;
sub all
	print"<tr align=center bgcolor='$list_names'>
	<th  width='$t1'><font color=$list_namest $font>Domain</font></th>
	<th  width='$t2'><font color=$list_namest $font>Result</font></th>
	<th  width='$t3'><font color=$list_namest $font>Action</font></th></tr></table></td></tr></table>";
	foreach $i (@tld)
		if($output eq "$stuff{'command'}.$splitz[0] is Unavailable")
			$isit[$lupe]="<tr align=center bgcolor='$unavailable'><td  width='$t1' ><a href='http://www.$stuff{'command'}.$splitz[0]' target='new'><b>$stuff{'command'}.$splitz[0]</b></a></td><td width='$t2'><b>$taken</b></td><td  width='$t3' bgcolor=$extras><a href='$me?command=$stuff{'command'}&type=$splitz[0]'>$details1</a></td></tr>";
		if($output eq "$stuff{'command'}.$splitz[0] is Available")
			$isit[$lupe]="<tr align=center bgcolor='$available'><td width='$t1'><b>$stuff{'command'}.$splitz[0]</b></td><td width='$t2'><b>$whatnext</b></td><td width='$t3' bgcolor=$extras><a href='$me?command=$stuff{'command'}&type=$splitz[0]'>$details2</a></td></tr>";
		if($output =~ /Server/g)
			my $tt=$t1+$t2+$t3;
			$isit[$lupe]="<tr align=center bgcolor='$errorbox'><td width='$tt'><font color=$errorboxt $font><b>$stuff{'command'}.$splitz[0]</b> $output</font></td></tr>";
		print "$isit[$lupe]</table></td></tr></table>";


sub my_header()
<HTML><head><title>Domain Check</title></head>
<body 	 vlink="$links"
<form name="defaulter" action="$me" method="post">
<tr align=left>
<td bgcolor="$webwhobar" height=15>
<a href="http://www.webwho.co.uk"><font color=$webwhobart $font><b>www.webwho.co.uk</b></a></font>

<tr align=center valign=middle><td bgcolor="$input_area">
<font color=$input_areat $font><b>www.</b></font>
<INPUT	STYLE="background-color:#ffffff" 

<select STYLE="background-color:#ffffff" NAME="type" SIZE="1">
print "<option";

if ($stuff{'type'} eq $alltext){print " selected";}
	print ">$alltext</option>";
foreach $i (@tld)   
	print "<option";
	if ($stuff{'type'} eq $splitz[0]){print " selected";}
	print ">$splitz[0]</option>";


sub start_table
<table width="$tw" border=0 bgcolor="black" cellspacing=0 cellpadding=0><tr valign=middle align=center><td valign=middle align=center><table border="0" cellpadding="0" cellspacing="$border" width="100%">

sub showone
print "<tr bgcolor='black'><td bgcolor='$list_names'>";
print "<font size=2 $font color=$list_namest><b> $output<br></b></font></td></tr><tr bgcolor='black'><td bgcolor='$details'><font size=2 $font color=$detailst>";

if($stuff{'type'} eq "biz")
	my $dummy=join("<br>",@result);
	($what,$lupe)=split(/OF THE AVAILABILITY OF A DOMAIN NAME./,$dummy);
	print "$lupe<hr>$what OF THE AVAILABILITY OF A DOMAIN NAME.";
	foreach $i (@result)
		print "$i<br>";
	foreach $i (@extras)
		print "$i<br>";
	print "</b></font></td></tr></table></td></tr></table>\n";

sub my_footer

# Whoopsydaisy
sub fatal_error()
<tr bgcolor='black' align=center>
<th colspan=3 bgcolor=red><font color=white  $font>$_[0]</font></th>



Добавлено: 15 Августа 2020 04:02:37 Добавил: Андрей Ковальчук

Menu Redirector


#                                                                  #
#               Menu Redirector                                    #
#               Kastle Internet Services                           #
#               http://www.kastle.net                              #
#               kastle@kastle.net                                  #
#                                                                  #
#                                                                  #
#  NO MODIFICATIONS ARE MADE TO THE CODE.                          #
#                                                                  #
#  Copyright (c) 1998 - Kastle Internet Services                   #
#  All rights reserved                                             #
#  Written & Tested by Kastle Internet Services                    #
#  gatekeeper@kastle.net                                           #
#                                                                  #
#                                                                  #
#  DISCLAIMER:                                                     #
#                                                                  #
#  In no event will Kastle Internet Services be liable to the user #
#  of this script or any third party for any damages, including    #
#  any lost profits, lost savings or other incidental,             #
#  consequential or special damages arising out of the operation   #
#  of or inability to operate this script, even if user has been   #
#  advised of the possibility of such damages.                     #
#                                                                  #



$gotourl = $FORM{'url'};

print "Location: $gotourl\n\n";

sub parse_form {

   read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
   @pairs = split(/&/, $buffer);
   foreach $pair (@pairs) {
      ($name, $value) = split(/=/, $pair);

      $value =~ tr/+/ /;
      $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;

      $FORM{$name} = $value;

Добавлено: 11 Июля 2020 07:57:34 Добавил: Андрей Ковальчук

Использование транзакций в программах на Perl

Вы хотите выполнить транзакцию в DBI-сценарии.

Используйте стандартный механизм поддержки транзакций DBI.

Механизм реализации транзакции в DBI базируется на явном управлении режимом автофиксации. Процедура выглядит так:

1. Если это еще не сделано, включите атрибут RaiseError и выключите Print-Error. Вы хотите, чтобы ошибки порождали исключения и ничего не выводили; если же оставить PrintError включенным, в некоторых случаях это может помешать обнаружению ошибки.

2. Отключите атрибут AutoCommit, чтобы фиксация происходила только по вашему указанию.

3. Выполните предложения транзакции в блоке eval так, чтобы ошибки вызывали исключение и завершали блок. Последним в блоке должен быть вызов commit(), который фиксировал бы транзакцию в случае успешного выполнения всех ее предложений.

4. После выполнения eval проверьте переменную $@. Если она содержит пустую строку, транзакция выполнена успешно. В противном случае этоозначает, что произошла какая-то ошибка, и $@ будет содержать сообщение об ошибке. Вызовите rollback() для отмены транзакции. Если вы хотите отобразить для пользователя сообщение об ошибке, выведите $@ перед вызовом rollback().

Следующий код показывает, как реализовать процедуру выполнения нашей транзакции. Текущие значения атрибутов обработки ошибок и автофиксации сохраняются перед выполнением транзакции, а после ее выполнения возвращаются в исходное состояние. Для ваших приложений это может оказаться избыточным. Например, если вы знаете, что RaiseError и PrintError уже установлены так, как надо, нет необходимости в их сохранении и восстановлении.

# сохраняем атрибуты обработки ошибок и автофиксации,
# затем убеждаемся в том, что они установлены корректно.
$save_re = $dbh->{RaiseError};
$save_pe = $dbh->{PrintError};
$save_ac = $dbh->{AutoCommit};
$dbh->{RaiseError} = 1; # исключение в случае ошибки
$dbh->{PrintError} = 0; # не выводить сообщение об ошибке
$dbh->{AutoCommit} = 0; # отключить автофиксацию
# передать немного денег от одного человека другому
$dbh->do ("UPDATE money SET amt = amt - 6 WHERE name = 'Eve'");
$dbh->do ("UPDATE money SET amt = amt + 6 WHERE name = 'Ida'");
# все предложения выполнены успешно, зафиксировать транзакцию
$dbh->commit ();
if ($@) # произошла ошибка
print "Transaction failed, rolling back. Error was:\n$@\n";
# откат внутри eval, чтобы ошибка отката не привела к завершению работы сценария
eval { $dbh->rollback (); };
# восстановить исходное состояние атрибутов
$dbh->{AutoCommit} = $save_ac;
$dbh->{PrintError} = $save_pe;
$dbh->{RaiseError} = $save_re;

Как видите, приходится проделать большую работу для того, чтобы выдать пару предложений. Чтобы упростить обработку транзакции, можно создать несколько функций, которые займутся обработкой до и после выполнения eval:

sub transact_init
my $dbh = shift;
my $attr_ref = {}; # создать хеш для хранения атрибутов$attr_ref->{RaiseError} = $dbh->{RaiseError};
$attr_ref->{PrintError} = $dbh->{PrintError};
$attr_ref->{AutoCommit} = $dbh->{AutoCommit};
$dbh->{RaiseError} = 1; # исключение в случае ошибки
$dbh->{PrintError} = 0; # не выводить сообщение об ошибке
$dbh->{AutoCommit} = 0; # отключить автофиксацию
return ($attr_ref); # вернуть атрибуты в вызывающую программу
sub transact_finish
my ($dbh, $attr_ref, $error) = @_;
if ($error) # произошла ошибка
print "Transaction failed, rolling back. Error was:\n$error\n";
# откат внутри eval, чтобы ошибка отката не привела
# к завершению работы сценария
eval { $dbh->rollback (); };
# восстановить исходное состояние атрибутов обработки ошибок и автофиксации
$dbh->{AutoCommit} = $attr_ref->{AutoCommit};
$dbh->{PrintError} = $attr_ref->{PrintError};
$dbh->{RaiseError} = $attr_ref->{RaiseError};
Если использовать две эти функции, наша транзакция значительно упрос-
$ref = transact_init ($dbh);
# передать деньги от одного человека другому
$dbh->do ("UPDATE money SET amt = amt - 6 WHERE name = 'Eve'");
$dbh->do ("UPDATE money SET amt = amt + 6 WHERE name = 'Ida'");
# все предложения выполнены успешно, зафиксировать транзакцию
$dbh->commit ();
transact_finish ($dbh, $ref, $@);

Начиная с DBI 1.20 есть альтернатива ручному управлению атрибутом Auto-Commit – можно начинать транзакцию, вызывая begin_work(). Этот метод отключает AutoCommit и автоматически разрешает его при последующем вызове commit() или rollback().

Добавлено: 23 Июля 2018 20:48:51 Добавил: Андрей Ковальчук

Срезы хешей

В полной аналогии со срезами массивов часть элементов хеша тоже может быть выделена в срез хеша. Помните пример с хранением результатов игры в боулинг в хеше %score? Мы можем извлечь эти результаты как в список элементов хеша, так и в срез. Эти два приема эквивалентны (хотя второй работает эффективнее и занимает меньше места):

my @three_scores = ($score{"barney"}, $score{"fred"}, $score{"dino"});
my @three_scores = @score{ qw/ barney fred dino/ };

Срез всегда является списком, и в записи среза хеша это обстоятельство указывается знаком @. Когда вы встречаете в программе Perl конструкцию вида @score{ ... }, сделайте то, что делает Perl, и обратите внимание на знак @ в начале и фигурные скобки в конце. Фигурные скобки означают, что происходит выборка из хеша, а знак @ – что вы получаете список элементов вместо одного (на которое бы указывал знак $). Как и в случае со срезами массивов, знак перед ссылкой на переменную ($ или @) определяет контекст индексного выражения. С префиксом $ выражение вычисляется в скалярном контексте для получения отдельного ключа. Но если в начале стоит знак @, индексное выражение вычисляется в списочном контексте для получения списка ключей.

Возникает логичный вопрос: раз мы говорим о хешах, почему здесь не используется знак %? Этот знак обозначает весь хеш; срез хеша (как и любой другой срез) всегда представляет собой список, а не хеш. В Perl символ $ всегда обозначает отдельный объект данных, символ @ обозначает список, а символ % обозначает весь хеш. Как вы видели со срезами массивов, срезы хешей могут использоваться вместо соответствующего списка элементов хеша во всех синтаксических конструкциях Perl. Таким образом, мы можем задать результаты некоторых партий в хеше (без изменения других элементов хеша) следующим образом:

my @players = qw/ barney fred dino /;
my @bowling_scores = (195, 205, 30);
@score{ @players } = @bowling_scores;

Последняя строка работает точно так же, как если бы мы выполнили присваивание списку из трех элементов:

($score{"barney"}, $score{"fred"}, $score{"dino"}).

Срезы хешей тоже могут интерполироваться. В следующем примере выводятся результаты для выбранной нами тройки игроков:

print "Tonight's players were: @players\n";
print "Their scores were: @score{@players}\n";

Добавлено: 20 Июля 2018 21:36:51 Добавил: Андрей Ковальчук

Срезы массивов

Предыдущий пример можно сделать еще проще. При создании срезов на базе массивов (вместо списков) круглые скобки необязательны. Следовательно, срез может выглядеть так:

my @numbers = @names[ 9, 0, 2, 1, 0 ];

Дело не сводится только к отсутствию круглых скобок; в действительности здесь используется другая запись обращения к элементам – срез массива. Ранее мы говорили, что символ @ в @names означает «все элементы». В Perl символ $ означает отдельное значение, а символ @ – список значений. Срез всегда является списком, и в синтаксисе среза массивов на это обстоятельство указывает знак @. Когда вы встречаете в программе Perl конструкцию вида @names[ ... ], сделайте то, что делает Perl, и обратите внимание на знак @ в начале и на квадратные скобки в конце. Квадратные скобки означают, что происходит индексирование массива, а знак @ – что вы получаете список1 элементов вместо одного значения (на которое бы указывал знак $).

Знак перед ссылкой на переменную ($ или @) определяет контекст индексного выражения. С префиксом $ выражение вычисляется в скалярном контексте. Но если в начале стоит знак @, индексное выражение вычисляется в списочном контексте для получения списка индексов. Таким образом, @names[ 2, 5 ] означает то же самое, что ($names, $names). Если вам нужен список значений, используйте запись со срезом массива. Везде, где требуется использовать список, вы можете использовать более простой срез массива. Однако срезы также могут использоваться в одном месте, где простые списки использоваться не могут, – срезы могут интерполироваться прямо в строку:

my @names = qw{ zero one two three four five six seven eight nine };
print "Bedrock @names[ 9, 0, 2, 1, 0 ]\n";

При попытке интерполировать @names выводятся элементы массива, разделенные пробелами. Если вместо этого интерполировать @names[ 9, 0, 2, 1, 0 ], вы получите только указанные элементы, разделенные пробелами. Вернемся к примеру с библиотекой. Допустим, программа обновляет адрес и телефон одного из читателей, потому что он только что переехал в новый дом. Если информация о нем поставляется в виде списка @items, обновление двух элементов массива может выполняться примерно так:

my $new_home_phone = "555-6099";
my $new_address = "99380 Red Rock West";
@items[2, 3] = ($new_address, $new_home_phone);

И снова срез массива обеспечивает более компактную запись, чем список элементов. В этом случае последняя строка эквивалентна присваиванию ($items, $items), но она более компактна и эффективна.

Добавлено: 20 Июля 2018 21:36:05 Добавил: Андрей Ковальчук

Упрощенная запись ключей хешей

В Perl предусмотрено множество способов сокращенной записи, упрощающих работу программиста. Вот один из них, весьма удобный: некоторые ключи хешей необязательно заключать в кавычки. Конечно, это возможно не для всех ключей, потому что ключ хеша может представлять собой произвольную строку. Однако ключи часто относительно просты. Если ключ хеша не содержит ничего кроме букв, цифр и символов подчеркивания и не начинается с цифры, кавычки можно опустить. Подобные простые строки без кавычек называются тривиальными словами (barewords). Эта сокращенная запись чаще всего применяется в самом распространенном месте записи ключей хеша: в фигурных скобках ссылки на элемент хеша. Например, вместо $score{"fred"} можно написать просто $score{fred}. Так как многие ключи хешей достаточно просты, отказ от кавычек действительно удобен. Но помните: если содержимое фигурных скобок не является тривиальным словом, Perl интерпретирует его как выражение.

Ключи хешей также часто встречаются при заполнении всего хеша по списку пар «ключ-значение». Большая стрелка (=>) между ключом и значением в этом случае особенно полезна, потому что она автоматически оформляет ключ как строку (и снова только если ключ является тривиальным словом):

# Хеш с результатами партий в боулинг
my %score = (
barney => 195,
fred => 205,
dino => 30,

Здесь проявляется еще одно важное отличие между «большой стрелкой» и запятой; тривиальное слово слева от большой стрелки неявно оформляется как строка (хотя все, что находится справа, остается без изменений). Данная особенность «большой стрелки» может использоваться не только при работе с хешами, однако этот вариант использования является самым распространенным.

Добавлено: 20 Июля 2018 21:33:59 Добавил: Андрей Ковальчук

Преобразование элементов списка

Другая распространенная задача – преобразование элементов списка. Предположим, имеется список чисел, которые необходимо перевести в «денежный формат» для вывода, как в функции &big_money. Однако исходные данные изменяться не должны; нам нужна измененная копия списка, используемая только для вывода. Одно из возможных решений:

my @data = (4.75, 1.5, 2, 1234, 6.9456, 12345678.9, 29.95);
my @formatted_data;
foreach (@data) {
push @formatted_data, &big_money($_);

Немного напоминает пример кода, приведенный в начале описания grep, не правда ли? Вероятно, вас не удивит, что альтернативное решение напоминает первый пример с grep:

my @data = (4.75, 1.5, 2, 1234, 6.9456, 12345678.9, 29.95);
my @formatted_data = map { &big_money($_) } @data;

Оператор map похож на grep, потому что он получает те же аргументы: блок, в котором используется $_, и список элементов для обработки. И функционирует он сходным образом: блок последовательно выполняется для каждого элемента списка, а $_ при каждой итерации представляет новый элемент списка. Но последнее выражение блока для map используется иначе: вместо логического признака оно определяет значение, включаемое в итоговый список. Любую конструкцию с grep или map можно переписать в виде эквивалентного цикла foreach с занесением элементов во временный массив, но короткая запись обычно и эффективнее, и удобнее. Результат map и grep представляет собой список, что позволяет напрямую передать его другой функции. В следующем примере отформатированные «денежные величины» выводятся в виде списка с отступами под заголовком:

print "The money numbers are:\n",
map { sprintf("%25s\n", $_) } @formatted_data;

Конечно, всю обработку можно выполнить «на месте» без использования временного массива @formatted_data:

my @data = (4.75, 1.5, 2, 1234, 6.9456, 12345678.9, 29.95);
print "The money numbers are:\n",
map { sprintf("%25s\n", &big_money($_) ) } @data;

У map, как и у grep, существует упрощенная форма синтаксиса. Если в качестве селектора используется простое выражение (вместо полноценного блока), поставьте это выражение, за которым следует запятая, на место блока:

print "Some powers of two are:\n",
map "\t" . ( 2 ** $_ ) . "\n", 0..15;

Добавлено: 20 Июля 2018 21:33:34 Добавил: Андрей Ковальчук

Отбор элементов списка

Иногда вас интересует лишь некоторое подмножество элементов из списка. Допустим, из списка чисел необходимо отобрать только нечетные числа или из текстового файла отбираются только те строки, в которых присутствует подстрока Fred. Как будет показано в этом разделе, задача отбора элементов списка легко решается при помощи оператора grep. Давайте начнем с первой задачи и выделим нечетные числа из большого списка. Ничего нового для этого нам не понадобится:

my @odd_numbers;
foreach (1..1000) {
push @odd_numbers, $_ if $_ % 2;

Для четного числа остаток от деления на 2 равен 0, а проверяемое условие ложно. Для нечетного числа остаток равен 1; значение истинно, поэтому в массив заносятся только нечетные числа. В этом коде нет ничего плохого, разве что он пишется и выполняется немного медленнее, чем следует, потому что в Perl имеется оператор grep:

my @odd_numbers = grep { $_ % 2 } 1..1000;

Этот фрагмент строит список из 500 нечетных чисел всего в одной строке кода. Как он работает? Первый аргумент grep содержит блок, в котором переменная $_ представляет текущий элемент списка. Блок возвращает логическое значение (true/false). Остальные аргументы определяют список элементов, в котором выполняется поиск. Оператор grep вычисляет выражение для каждого элемента списка по аналогии с циклом foreach. Элементы, для которых последнее выражение в блоке возвращает истинное значение, включаются в итоговый список grep. Во время работы grep переменная $_ последовательно представляет один элемент списка за другим. Аналогичное поведение уже встречалось нам в цикле foreach. Как правило, изменять $_ в выражении grep не рекомендуется, потому что это приведет к повреждению исходных данных. Оператор grep унаследовал свое имя от классической утилиты UNIX, которая отбирает строки из файла по регулярным выражениям. Оператор Perl grep решает ту же задачу, но обладает гораздо большими возможностями. В следующем примере из файла извлекаются только те строки, в которых присутствует подстрока fred:

my @matching_lines = grep { /\bfred\b/i } <FILE>;

У grep также существует упрощенный вариант синтаксиса. Если в качестве селектора используется простое выражение (вместо целого блока), замените блок этим выражением, за которым следует запятая. В упрощенной записи предыдущий пример выглядит так:

my @matching_lines = grep /\bfred\b/i, <FILE>;

Добавлено: 20 Июля 2018 21:32:56 Добавил: Андрей Ковальчук

Перехват ошибок в блоках eval

Иногда даже самый обычный, повседневный код приводит к фатальным ошибкам в программе. Любая из следующих типичных команд может стать причиной аварийного завершения:

$barney = $fred / $dino; # Деление на нуль?
print "match\n" if /^($wilma)/; # Некорректное регулярное выражение?
open CAVEMAN, $fred # Ошибка пользователя приводит к сбою die?
or die "Can't open file '$fred' for input: $!";

Некоторые из этих ошибок можно выявить заранее, но обнаружить их все невозможно. (Как проверить строку $wilma из этого примера и убедиться в том, что она содержит корректное регулярное выражение?) К счастью, в Perl имеется простой способ перехвата фатальных ошибок – проверяемый код заключается в блок eval:

eval { $barney = $fred / $dino } ;

Даже если переменная $dino равна нулю, эта строка не приведет к сбою программы. В действительности eval является выражением (а не управляющей конструкцией, как while или foreach), поэтому точка с запятой в конце блока обязательна. Если во время выполнения блока eval происходит фатальная (в обычных условиях) ошибка, блок продолжает работать, но программа аварийно не завершается. Таким образом, сразу же после завершения eval желательно проверить, завершился ли блок нормально или произошла фатальная ошибка. Ответ содержится в специальной переменной $@. Если в блоке была перехвачена фатальная ошибка, $@ будет содержать «последние слова» программы – сообщение вида «Недопустимое деление на нуль в my_program строка 12». Если ошибки не было, переменная $@ пуста. Конечно, это означает, что $@ содержит удобный логический признак для проверки (true в случае ошибки), поэтому после блоков eval часто встречается команда следующего вида:

print "An error occurred: $@" if $@;

Блок eval является полноценным блоком, поэтому он определяет новую область видимости для лексических (my) переменных. В следующем фрагменте показан блок eval в действии:

foreach my $person (qw/ fred wilma betty barney dino pebbles /) {
eval {
open FILE, "<$person"
or die "Can't open file '$person': $!";
my($total, $count);
while (<FILE>) {
$total += $_;
my $average = $total/$count;
print "Average for file $person was $average\n";
&do_something($person, $average);
if ($@) {
print "An error occurred ($@), continuing\n";

Сколько возможных фатальных ошибок перехватывает этот блок? Если произойдет ошибка при открытии файла, она будет перехвачена. Вычисление среднего арифметического может привести к делению на нуль, и эта ошибка тоже перехватывается. Даже вызов загадочной функции &do_something защищается от фатальных ошибок, потому что блок eval перехватывает все фатальные ошибки, происходящие во время его активности. (В частности, это будет удобно, если вы вызываете пользовательскую функцию, написанную другим программистом, но не знаете, насколько надежно она написана.) Если ошибка происходит в ходе обработки одного из файлов, мы получим сообщение об ошибке, но программа спокойно перейдет к следующему файлу. Блоки eval даже могут вкладываться в другие блоки eval. Внутренний блок перехватывает ошибки во время выполнения, не позволяя им добраться до внешних блоков. (Конечно, после завершения внутреннего блока eval можно «перезапустить» ошибку при помощи die, чтобы она была перехвачена внешним блоком.) Блок eval перехватывает любые ошибки, происходящие во время выполнения, в том числе и ошибки при вызове функций (как показано в предыдущем примере).

Ранее мы уже упоминали о том, что eval является выражением, и поэтому после завершающей фигурной скобки необходима точка с запятой. Но как и любое выражение, eval имеет некоторое возвращаемое значение. При отсутствии ошибок значение вычисляется по аналогии с функциями: как результат последнего вычисленного выражения или как значение, возвращаемое на более ранней стадии необязательным ключевым словом return. А вот другой способ выполнения вычислений, при котором вам не нужно беспокоиться о делении на нуль:

my $barney = eval { $fred / $dino };

Если eval перехватывает фатальную ошибку, возвращаемое значение представляет собой либо undef, либо пустой список (в зависимости от контекста). Таким образом, в предыдущем примере $barney либо содержит правильный результат деления, либо undef; проверять $@ необязательно (хотя, вероятно, перед дальнейшим использованием $barney стоит включить проверку defined($barney)). Существуют четыре вида проблем, которые eval перехватить не может. Первую группу составляют очень серьезные ошибки, нарушающие работу Perl, – нехватка памяти или получение необработанного сигнала. Поскольку Perl при этом перестает работать, перехватить эти ошибки он не сможет. Конечно, синтаксические ошибки в блоке eval перехватываются на стадии компиляции – они никогда не возвращаются в $@. Оператор exit завершает программу немедленно, даже если он вызывается в пользовательской функции в блоке eval. (Отсюда следует, что при написании пользовательской функции в случае возникновения проблем следует использовать die вместо exit.)

Четвертую и последнюю разновидность проблем, не перехватываемых блоком eval, составляют предупреждения – пользовательские (из warn) или внутренние (включаемые ключом командной строки –w или директивой use warnings). Для перехвата предупреждений существует специальный механизм, не связанный с eval; за информацией обращайтесь к описанию псевдосигнала __WARN__ в документации Perl. Стоит также упомянуть еще об одной форме eval, которая может быть опасна при неправильном использовании. Более того, некоторые люди считают, что eval вообще не следует использовать в программах по соображениям безопасности. Действительно, eval следует использовать с осторожностью, но здесь имеется в виду другая форма eval – «eval для строк». Если же за ключевым словом eval сразу же следует блок программного кода в фигурных скобках, беспокоиться не о чем – эта разновидность eval безопасна.

Добавлено: 20 Июля 2018 21:31:40 Добавил: Андрей Ковальчук

Отправка и прием сигналов

Сигнал UNIX представляет собой крошечное сообщение, отправленное процессу. Он не может содержать подробной информации; представьте себе автомобильный сигнал – что он может означать? «Осторожно, здесь обвалился мост», или «Светофор переключился, можно ехать», или «Остановись, у тебя на крыше ребенок», или «Привет всем»? К счастью, понять смысл сигнала UNIX несколько проще, потому что в каждой из описанных ситуаций используется свой сигнал. Сигналы идентифицируются по именам (например, SIGINT – «сигнал прерывания») и коротким числовым кодам (в диапазоне от 1 до 16, от 1 до 32 или от 1 до 63 в зависимости от вашей разновидности UNIX). Сигнал обычно отправляется при обнаружении важного события. Например, при нажатии клавиш прерывания программы (чаще всего ControlQC) на терминале всем процессам, присоединенным к этому терминалу, отправляется сигнал SIGINT. Некоторые сигналы автоматически отправляются системой, но они также могут отправляться другими процессами.

Вы можете отправить из процесса Perl сигнал другому процессу, но для этого необходимо знать идентификатор целевого процесса. Определить его не так просто3, но предположим, вы хотите отправить сигнал SIGINT процессу 4201. Делается это достаточно просто:

kill 2, 4201 or die "Cannot signal 4201 with SIGINT: $!";

Функция называется kill, потому что сигналы очень часто применяются для остановки процесса, выполнение которого занимает слишком много времени. Вместо 2 также можно использовать строку 'INT', так как числовой код 2 соответствует сигналу SIGINT. Если процесс не существует4, вы получите значение false, поэтому этот способ позволяет проверить, жив ли процесс. Специальный сигнал с номером 0 означает примерно следующее: «Просто проверить, смогу ли я отправить сигнал, если захочу… Но я пока не хочу, так что и отправлять ничего не нужно». Таким образом, зондирование процесса может выглядеть примерно так:

unless (kill 0, $pid) {
warn "$pid has gone away!";

Пожалуй, принимать сигналы немного интереснее, чем отправлять их. Зачем это может быть нужно? Допустим, ваша программа создает временные файлы в каталоге /tmp, которые удаляются в конце работы программы. Если ктоQто нажмет ControlQC во время выполнения, при аварийном завершении в /tmp останется «мусор», а это крайне невежливо. Проблема решается обработчиком сигнала, который позаботится об очистке:

my $temp_directory = "/tmp/myprog.$$"; # Каталог для временных файлов
mkdir $temp_directory, 0700 or die "Cannot create $temp_directory: $!";
sub clean_up {
unlink glob "$temp_directory/*";
rmdir $temp_directory;
sub my_int_handler {
die "interrupted, exiting...\n";
$SIG{'INT'} = 'my_int_handler';
. # Время идет, программа работает, в каталоге создаются
. # временные файлы. Потом кто-то нажимает Control-C.
# Конец нормального выполнения

Присваивание элементу специального хеша %SIG активизирует обработчик сигнала (пока он не будет снова отменен). Ключом является имя сигнала (без префикса SIG), а значением – строка1 с именем функции (без знака &). В дальнейшем при получении сигнала SIGINT Perl немедленно прерывает свою текущую работу и передает управление заданной функции. Функция удаляет временные файлы, а затем завершает работу программы. Если никто не нажал Control-C, функция &clean_up все равно будет вызвана в конце нормального выполнения программы. Если функция возвращает управление вместо вызова die, выполнение продолжается с того места, на котором оно было прервано. Это может быть полезно, если сигнал должен прервать какую-то операцию без завершения всей программы. Допустим, обработка каждой строки файла занимает несколько секунд, и вы хотите отменить общую обработку при получении сигнала прерывания, но только не на середине обработки строки. Установите флаг в обработчике прерывания и проверяйте его состояние в конце обработки каждой строки:

my $int_count;
sub my_int_handler { $int_count++ }
$SIG{'INT'} = 'my_int_handler';
$int_count = 0;
while (<SOMEFILE>) {
... Обработка в течение нескольких секунд ...
if ($int_count) {
# Получен сигнал прерывания !
print "[processing interrupted...]\n";

Во время обработки каждой строки значение $int_count равно 0. Если никто не нажал Control-C, цикл переходит к следующей строке. Но при поступлении сигнала прерывания обработчик сигнала увеличивает флаг $int_count, а это приводит к выходу из цикла при завершающей проверке. Итак, при получении сигнала можно либо установить флаг, либо завершить работу программы; собственно, на этом возможности обработки сигналов заканчиваются. Впрочем, текущая реализация обработчиков сигналов неидеальна1; постарайтесь свести объем выполняемых действий к минимуму, или ваша программа может «упасть» в самый неподходящий момент.

Добавлено: 20 Июля 2018 21:30:51 Добавил: Андрей Ковальчук


Кроме высокоуровневых интерфейсов, описанных ранее, Perl предоставляет практически прямой доступ к низкоуровневым системным функциям UNIX и других систем. Если ранее вы никогда не имели дела с этой областью1, вероятно, этот раздел можно пропустить. Привести подробное описание в этой главе не удастся, но, по крайней мере, разберем в общих чертах реализацию следующего вызова:

system "date";
При использовании низкоуровневых системных вызовов эта задача
реализуется так:
defined(my $pid = fork) or die "Cannot fork: $!";
unless ($pid) {
# Дочерний процесс
exec "date";
die "cannot exec date: $!";
# Родительский процесс
waitpid($pid, 0);

Мы проверяем возвращаемое значение fork, которое будет равно undef в случае сбоя. Обычно вызов завершается удачно, а к следующей строке переходят уже два разных процесса, но только родительский процесс содержит ненулевое значение в $pid, поэтому только дочерний процесс выполнит функцию exec. Родительский процесс пропускает этот вызов и выполняет функцию waitpid, ожидающую завершения этого конкретного дочернего процесса. Если это описание покажется полной абракадаброй, просто запомните, что вы можете пользоваться функцией system, и над вами никто не будет смеяться. За все дополнительные хлопоты вы получаете полный контроль за созданием каналов, переназначением файловых дескрипторов и информацию об идентификаторах процесса и его родителя (если он известен). Но как уже говорилось ранее, тема ветвления немного сложна для этой главы. За дополнительной информацией обращайтесь к manстранице perlipc (или любой хорошей книге по прикладному программированию для вашей системы).

Добавлено: 20 Июля 2018 21:30:12 Добавил: Андрей Ковальчук

Процессы как файловые дескрипторы

До настоящего момента рассматривался исключительно синхронный запуск процессов, когда Perl заправляет всем происходящим, запускает команду, (обычно) дожидается ее завершения и получает вывод. Но Perl также может запускать дочерние процессы, которые существуют самостоятельно и взаимодействуют с Perl на долгосрочной основе вплоть до завершения задачи. В синтаксисе запуска параллельного дочернего процесса команда задается в качестве «имени файла» при вызове open, а перед или после нее ставится вертикальная черта. Этот синтаксис часто называется открытием канала:

open DATE, "date|" or die "cannot pipe from date: $!";
open MAIL, "|mail merlyn" or die "cannot pipe to mail: $!";

В первом примере, когда символ | стоит справа, стандартный вывод запущенной команды связывается с файловым дескриптором DATE, открытым для чтения, по аналогии с выполнением date | your_program в командном процессоре. Во втором примере, когда символ | стоит слева, стандартный ввод команды соединяется с дескриптором MAIL, открытым для записи, по аналогии с командой your_program | mail merlyn. В обоих случаях команда продолжает работать независимо от процесса Perl. Если создать дочерний процесс не удалось, вызов open завершается неудачей. Если команда не существует или некорректна, это (обычно) не воспринимается как ошибка при открытии, но приводит к ошибке при закрытии. Вскоре мы вернемся к этому вопросу. Остальная часть программы не знает, что файловый дескриптор открыт для процесса, а не для файла – более того, это неважно, и чтобы узнать об этом, придется основательно потрудиться. Таким образом, чтобы получить данные из файлового дескриптора, открытого для чтения, достаточно выполнить обычную операцию чтения:

my $now = <DATE>;

А чтобы отправить данные процессу mail (ожидающему получить тело сообщения для merlyn в стандартном вводе), хватит простой команды print с файловым дескриптором:

print MAIL "The time is now $now"; # Предполагается, что $now
# завершается символом новой строки

Короче говоря, вы можете считать, что эти дескрипторы связаны с «волшебными файлами»: один файл содержит вывод команды date, а другой автоматически передает данные команде mail. няет предыдущее значение, так что сохраните его побыстрее, если собираетесь использовать в будущем. (Переменная $? также содержит код завершения последней команды system или ` `, если вас это интересует.) Процессы синхронизируются точно так же, как цепочки конвейерных команд. Если вы пытаетесь прочитать данные, а данные недоступны, процесс приостанавливается (без потребления дополнительного процессорного времени) до тех пор, пока программа-отправитель не «заговорит» снова.

Аналогично, если записывающий процесс «опередит» читающий процесс, он приостанавливается до тех пор, пока последний не «догонит» его. Между процессами создается промежуточный буфер обмена данными (обычно 8 Кбайт или около того), так что абсолютно точная синхронизация не требуется. Зачем связывать процессы с файловыми дескрипторами? Прежде всего, это единственный простой способ передачи данных процессу на основании результатов вычислений. При чтении данных обратные апострофы обычно гораздо удобнее, если только данные не должны обрабатываться сразу же после записи. Например, команда UNIX find ищет файлы по атрибутам и при относительно большом количестве файлов (например, при рекурсивном поиске от корневого каталога) выполняется сравнительно долго. Команду find можно выполнить в обратных апострофах, но часто бывает удобнее получать результаты по мере их поступления:

open F, "find / -atime +90 -size +1000 -print|" or die "fork: $!";
while (<F>) {
printf "%s size %dK last accessed on %s\n",
$_, (1023 + -s $_)/1024, -A $_;

Команда find находит файлы, к которым не было обращений за последние 90 дней, превышающие размером 1000 блоков. (Эти файлы являются хорошими кандидатами для перемещения на архивные носители.) В процессе поиска Perl ждет. При обнаружении очередного файла Perl реагирует на входящее имя и выводит информацию о файле для дальнейшего анализа. Если бы команда поиска выполнялась в обратных апострофах, мы бы не получили никаких данных до завершения find. Всегда полезно знать, что команда по крайней мере работает.

Добавлено: 20 Июля 2018 21:29:44 Добавил: Андрей Ковальчук

Обратные апострофы в списочном контексте

Если результат выполнения команды состоит из нескольких строк, в скалярном контексте обратные апострофы возвращают одну длинную строку с внутренними символами новой строки. Однако при использовании той же строки в списочном контексте создается список, один элемент которого соответствует одной строке вывода. Например, команда UNIX who обычно выдает строку текста для каждого текущего пользователя в системе:

merlyn tty/42 Dec 7 19:41
rootbeer console Dec 2 14:15
rootbeer tty/12 Dec 6 23:00

В левом столбце указано имя пользователя, в среднем – имя tty (т. е. имя подключения пользователя к компьютеру), а в оставшейся части строки выводится дата и время входа (и возможно, дополнительная информация, но не в этом примере). В скалярном контексте вся информация возвращается в одной строке, и нам придется разбивать ее самостоятельно:

my $who_text = `who`;

Но в списочном контексте данные сразу возвращаются с разбивкой по строкам:

my @who_lines = `who`;

@who_lines содержит элементы, каждый из которых завершается символом новой строки. Конечно, можно удалить все эти символы функцией chomp, но давайте пойдем в другом направлении. Если разместить вызов в обратных апострофах в заголовке foreach, цикл автоматически переберет все строки, последовательно присваивая каждую из них переменной $_:

foreach (`who`) {
my($user, $tty, $date) = /(\S+)\s+(\S+)\s+(.*)/;
$ttys{$user} .= "$tty at $date\n";

Для приведенных выше данных цикл выполняется три раза. (Вероятно, в вашей системе количество активных входов будет больше трех.) Обратите внимание на поиск по регулярному выражению; в отсутствие оператора привязки (=~) он применяется к переменной $_, и это хорошо, потому что именно в этой переменной хранятся выходные данные команды. Регулярное выражение ищет шаблон вида «непустое слово, пропуски, непустое слово, пропуски, а затем весь остаток строки до символа новой строки, но не включая его (так как точка по умолчанию не совпадает с символом новой строки)». Таким образом, при первой итерации в $1 сохраняется строка "merlyn", в $2 – строка "tty/42", а в $3 – строка "Dec 7 19:41". Однако регулярное выражение применяется в списочном контексте, поэтому вместо логического значения «совпало или нет» мы получим список заполненных переменных. Переменная $user заполняется строкой "merlyn" и т. д. Вторая команда в этом цикле просто сохраняет tty и дату, присоединяя их к текущему значению в хеше (возможно, undef), потому что пользователь может присутствовать в списке несколько раз (как пользователь "rootbeer" в нашем примере).

Добавлено: 20 Июля 2018 21:29:08 Добавил: Андрей Ковальчук

Обратные апострофы и сохранение вывода

При использовании обеих функций system и exec выходные данные запущенной команды направляются в стандартный поток вывода Perl. Иногда бывает нужно сохранить этот вывод в строковом виде для дальнейшей обработки. Задача решается просто: замените апострофы или кавычки при создании переменной обратными апострофами ` `:

my $now = `date`; # Сохранить вывод date
print "The time is now $now"; # Символ новой строки уже присутствует

Обычно команда date выдает в стандартный вывод строку длиной приблизительно 30 символов. Строка содержит текущую дату и время и завершается символом новой строки. Когда мы заключаем вызов date в обратные апострофы, Perl выполняет команду date, сохраняет ее вывод в виде строкового значения и (в данном случае) присваивает ее переменной $now. Этот синтаксис очень близок к использованию обратных апострофов
в командном процессоре UNIX. Однако командный процессор также удаляет завершающий символ новой строки, чтобы упростить дальнейшее использование значения. Perl действует честнее: он выдает настоящие выходные данные. Чтобы получить тот же результат в Perl, нам пришлось бы обработать результат дополнительной операцией chomp:

chomp(my $no_newline_now = `date`);
print "A moment ago, it was $no_newline_now, I think.\n";

Значение в обратных апострофах интерпретируется как форма sуstem с одним аргументом по правилам строк в кавычках (то есть с интерпретацией служебных последовательностей с символом \ и расширением переменных). Например, для получения документации по функциям Perl мы могли бы многократно вызвать perldoc с разными аргументами:

my @functions = qw{ int rand sleep length hex eof not exit sqrt umask };
my %about;
foreach (@functions) {
$about{$_} = `perldoc -t -f $_`;

Переменная $_ содержит разные значения при каждом вызове, что позволяет нам получать результаты разных вызовов, отличающихся только одним из параметров. Если эти функции вам еще незнакомы, загляните в документацию и посмотрите, что они делают. В синтаксисе обратных апострофов нет простого аналога режима «обычных» апострофов1: ссылки на переменные и комбинации с \ расширяются всегда. Также не существует простого аналога версии system с несколькими аргументами (выполняемой без участия командного процессора). Если команда в обратных апострофах достаточно сложна, для ее интерпретации автоматически активизируется UNIX Bourne Shell (или другой командный процессор, используемый в вашей системе). Постарайтесь обходиться без обратных апострофов в тех местах, где вывод не сохраняется. Пример:

print "Starting the frobnitzigator:\n";
`frobnitz -enable`; # Не делайте этого!
print "Done!\n";

Дело в том, что Perl приходится выполнять ряд дополнительных действий для сохранения вывода команды (который немедленно теряется), к тому же вы теряете возможность использования system с несколькими аргументами для более точного управления списком аргументов. Итак, и с точки зрения эффективности, и с точки зрения безопасности system оказывается предпочтительнее. Стандартный поток ошибок наследуется командой в обратных апострофах от Perl. Если команда выводит сообщения об ошибках в стандартный поток ошибок, скорее всего, они будут выведены на терминал; это собьет с толку пользователя, который не запускал команду frobnitz. Если вы предпочитаете сохранять сообщения об ошибках в стандартном выводе, воспользуйтесь стандартным механизмом «слияния стандартного потока ошибок со стандартным потоком вывода» командного процессора; на языке UNIX это называется записью 2>&1:

my $output_with_errors = `frobnitz -enable 2>&1`;

Но в этом случае стандартный поток ошибок смешивается со стандартным выводом по аналогии с тем, как это происходит при выводе на терминал (хотя, возможно, в несколько иной последовательности из-за буферизации). Если вы предпочитаете разделить поток вывода и поток ошибок, существует пара более сложных решений. Стандартный поток ввода также наследуется от текущего стандартного ввода Perl. Как правило, команды, заключаемые в обратные апострофы, все равно не читают данные из стандартного ввода, так что это не создает особых проблем. Но допустим, что команда date спрашивает, какой часовой пояс вам нужен (см. ранее). Строка с запросом направляется в стандартный вывод, сохраняется как часть результата, после чего команда date пытается получить данные из стандартного ввода. Но пользователь не видел запрос и не знает, что ему нужно вводить!

Вскоре он позвонит вам и скажет, что ваша программа «зависла». Итак, держитесь подальше от команд, читающих данные из стандартного ввода. Если вы не уверены в том, читаются данные из стандартного ввода или нет, добавьте перенаправление из /dev/null:

my $result = `some_questionable_command arg arg argh </dev/null`;

В этом случае дочерний процесс командного процессора перенаправит ввод из /dev/null, а «внук» some_questionable_command в худшем случае попытается прочитать данные и немедленно получит признак конца файла.

Добавлено: 20 Июля 2018 21:28:11 Добавил: Андрей Ковальчук

Переменные среды

При запуске другого процесса (любым из описанных способов) может возникнуть необходимость в подготовке среды выполнения. Как упоминалось ранее, процесс можно запустить с определенным рабочим каталогом, который наследуется от текущего процесса. Другой стандартный аспект конфигурации – переменные среды. Из всех переменных среды наибольшей известностью пользуется PATH. (Если вы никогда не слышали о ней, вероятно, в вашей системе переменные среды не поддерживаются.) В UNIX и других аналогичных системах PATH содержит разделенный двоеточиями список каталогов, в которых могут храниться программы. Когда вы вводите команду (например, rm fred), система последовательно ищет файл rm во всех перечисленных каталогах. Perl (или ваша система) использует PATH всегда, когда потребуется найти запускаемую программу. Если программа в свою очередь запускает другие программы, они тоже ищутся среди каталогов PATH. (Конечно, если команда запускается по полному имени, например /bin/echo, поиск в PATH оказывается лишним, но обычно запуск по полному имени слишком неудобен.)

В Perl для работы с переменными среды используется специальный хеш %ENV; каждый ключ хеша соответствует одной переменной. В начале выполнения программы %ENV содержит значения, унаследованные от родительского процесса (чаще всего командного процессора). Модификация хеша изменяет переменные среды, которые наследуются новыми процессами и могут использоваться самим Perl. Допустим, вы хотите запустить системную утилиту make (которая обычно запускает другие программы) так, чтобы поиск команд (включая саму команду make) начинался с приватного каталога. Также будем считать, что при запуске команды переменная среды IFS не должна устанавливаться, потому что это может нарушить работу make или другой подкоманды. Вот как это делается:

$ENV{'PATH'} = "/home/rootbeer/bin:$ENV{'PATH'}";
delete $ENV{'IFS'};
my $make_result = system "make";

Создаваемые процессы обычно наследуют от своих родителей переменные среды, стандартный рабочий каталог, стандартные потоки ввода, вывода и ошибок, а также ряд других эзотерических параметров. За дополнительной информацией обращайтесь к документации по программированию для вашей системы. (Учтите, что в большинстве систем программа не может изменять среду командного процессора или другого родительского процесса, запустившего ее.)

Добавлено: 20 Июля 2018 21:27:11 Добавил: Андрей Ковальчук