[devel]

这里是perl脚本共享区
请注明脚本的作者，最好是附加上一些简单的解释。要是从这里转贴，请注明来自黄嘴企鹅论坛www.linuxsir.com

一些脚本
http://www.cpan.org/scripts/index.html
ftp://ftp.funet.fi/pub/languages/perl/CPAN/scripts

注意：所有的置顶贴子禁止闲谈和灌水，谢谢合作。

[devel]

来自internet

The echo client and echo server don't play well together because they don't agree on the end of line character (however, the server will work correctly with telnet, and the client will work well with other echo servers, including tcp_echo_serv1.pl).

To make the client talk to the server, you must modify it to append CRLF sequences to the end of each input line, as shown in this revised example.

#!/usr/bin/perl
# file: tcp_echo_cli1.pl
# Figure 4.1: A TCP Echo Client

# usage: tcp_echo_cli1.pl [host] [port]

use strict;
use Socket qw(:DEFAULT :crlf);
use IO::Handle;
my ($bytes_out,$bytes_in) = (0,0);

my $host = shift || 'localhost';
my $port = shift || getservbyname('echo','tcp');

my $protocol = getprotobyname('tcp');
$host = inet_aton($host) or die "$host: unknown host";

socket(SOCK, AF_INET, SOCK_STREAM, $protocol) or die "socket() failed: $!";
my $dest_addr = sockaddr_in($port,$host);
connect(SOCK,$dest_addr) or die "connect() failed: $!";

SOCK->autoflush(1);

while (my $msg_out = <>) {
chomp $msg_out;
$msg_out .= CRLF;
print SOCK $msg_out;
my $msg_in = <SOCK>;
print $msg_in;

$bytes_out += length($msg_out);
$bytes_in += length($msg_in);
}

close SOCK;
print STDERR "bytes_sent = $bytes_out, bytes_received = $bytes_in\n";

[devel]

来自intenel,这个脚本提供一个TCP echo 服务，版本是2

#!/usr/bin/perl
# file: tcp_echo_serv2.pl
# Figure 5.4: The reverse echo server, using IO::Socket

# usage: tcp_echo_serv2.pl [port]

use strict;
use IO::Socket qw(:DEFAULT :crlf);
use constant MY_ECHO_PORT => 2007;
$/ = CRLF;
my ($bytes_out,$bytes_in) = (0,0);

my $quit = 0;
$SIG{INT} = sub { $quit++ };

my $port = shift || MY_ECHO_PORT;

my $sock = IO::Socket::INET->new( Listen => 20,
LocalPort => $port,
Timeout => 60*60,
Reuse => 1)
or die "Can't create listening socket: $!\n";

warn "waiting for incoming connections on port $port...\n";
while (!$quit) {
next unless my $session = $sock->accept;

my $peer = gethostbyaddr($session->peeraddr,AF_INET) || $session->peerhost;
my $port = $session->peerport;
warn "Connection from [$peer,$port]\n";

while (<$session>) {
$bytes_in += length($_);
chomp;
my $msg_out = (scalar reverse $_) . CRLF;
print $session $msg_out;
$bytes_out += length($msg_out);
}
warn "Connection from [$peer,$port] finished\n";
close $session;
}

print STDERR "bytes_sent = $bytes_out, bytes_received = $bytes_in\n";
close $sock;

[devel]

来自INTERNET 使用IO::Socket的daytime客户。


#!/usr/bin/perl
# file: time_of_day_tcp2.pl
# Figure 5.1 Time of day client using IO::Socket

use strict; #使用标准的格式。
use IO::Socket qw(:DEFAULT :crlf); #2加载模块，

my $host = shift || 'localhost';#从命令行获取远程主机的名字。

$/ = CRLF;#设置行尾分割符。
my $socket = IO::Socket::INET->new("$host:daytime")
or die "Can't connect to daytime service at $host: $!\n"; #6,7创建套解字。
chomp(my $time = $socket->getline); #取的时间并把它赋给一个句柄。
print $time,"\n";



运行：
#perl time_of_day_tcp2.pl wuarchive.wustl.edu
TIME

[home]

来自internet使用Mial::Internet发送电子邮件。

#!/usr/bin/perl -w
use Mail::Internet; #load module.

my $head=Mail::Header->new;
$head->add(From => 'John Doe <doe@acme.org>'); #创建邮件的头部，use Mail::Header model.please look at perldoc Mail::Header
$head->add(To => 'L Stein <lstein@lsjs.org>' );
$head->add(Cc => 'jac@acome.org');
$head->add(Cc => 'vvd@acome.org');
$head->add(Subject => 'hello there');

my $body = <<END ; #editor contain of mail
This is just a simple e-mail message.
Nothing to get excited about.

Regards, JD
END

$mail =Mail::Internet->new(Header => $head ,#这几行是创建Mail::Internet对象，
Body => [$body] ,
Modify => 1 );
print $mail->send('sendmail'); #发送邮件。

[devel]

一个客户端的聊天程序，来自INTERNET。

#!/usr/bin/perl -w
# file: chat_client.pl
# Figure 19.2: Chat client using UDP

use strict;
use IO::Socket;
use IO::Select;
use ChatObjects::ChatCodes;
use ChatObjects::Comm;
#以上几行是导入模块。

$SIG{INT} = $SIG{TERM} = sub { exit 0 };
my ($nickname,$server);
#以上两行是：安装信号处理程序。
# dispatch table for commands from the user
my %COMMANDS = (
channels => sub { $server->send_event(LIST_CHANNELS) },
join => sub { $server->send_event(JOIN_REQ,shift) },
part => sub { $server->send_event(PART_REQ,shift) },
users => sub { $server->send_event(LIST_USERS) },
public => sub { $server->send_event(SEND_PUBLIC,shift) },
private => sub { $server->send_event(SEND_PRIVATE,shift) },
login => sub { $nickname = do_login() },
quit => sub { undef },
);

# dispatch table for messages from the server
my %MESSAGES = (
ERROR() => \&error,
LOGIN_ACK() => \&login_ack,
JOIN_ACK() => \&join_part,
PART_ACK() => \&join_part,
PUBLIC_MSG() => \&public_msg,
PRIVATE_MSG() => \&private_msg,
USER_JOINS() => \&user_join_part,
USER_PARTS() => \&user_join_part,
CHANNEL_ITEM() => \&list_channel,
USER_ITEM() => \&list_user,
);
#以上是定义调度表。

# Create and initialize the UDP socket
my $servaddr = shift || 'localhost';
my $servport = shift || 2027;
$server = ChatObjects::Comm->new(PeerAddr => "$servaddr:$servport") or die $@;
#以上是创建UDP套接字和服务器封装器。

# Try to log in
$nickname = do_login();
die "Can't log in.\n" unless $nickname;

# Read commands from the user and messages from the server
my $select = IO::Select->new($server->socket,\*STDIN);
LOOP:
while (1) {
my @ready = $select->can_read;
foreach (@ready) {
if ($_ eq \*STDIN) {
do_user(\*STDIN) || last LOOP;
} else {
do_server($_);
}
}
}

# called to handle a command from the user
sub do_user {
my $h = shift;
my $data;
return unless sysread($h,$data,1024); # longest line
return 1 unless $data =~ /\S+/;
chomp($data);
my($command,$args) = $data =~ m!^/(\S+)\s*(.*)!;
($command,$args) = ('public',$data) unless $command;
my $sub = $COMMANDS{lc $command};
return do_help() unless $sub;
return $sub->($args);
}

# called to handle a message from the server
sub do_server {
die "invalid socket" unless my $s = ChatObjects::Comm->sock2server(shift);
die "can't receive: $!" unless
my ($mess,$args) = $s->recv_event;
my $sub = $MESSAGES{$mess} || return warn "$mess: unknown message from server\n";
$sub->($mess,$args);
return $mess;
}

# try to log in (repeatedly)
sub do_login {
$server->send_event(LOGOFF,$nickname) if $nickname;
my $nick = get_nickname(); # read from user
my $select = IO::Select->new($server->socket);

for (my $count=1; $count <= 5; $count++) {
warn "trying to log in ($count)...\n";
$server->send_event(LOGIN_REQ,$nick);
next unless $select->can_read(6);
return $nick if do_server($server->socket) == LOGIN_ACK;
$nick = get_nickname();
}

}

# prompt user for his nickname
sub get_nickname {
while (1) {
local $| = 1;
print "Your nickname: ";
last unless defined(my $nick = <STDIN>);
chomp($nick);
return $nick if $nick =~ /^\S+$/;
warn "Invalid nickname. Must contain no spaces.\n";
}
}

# handle an error message from server
sub error {
my ($code,$args) = @_;
print "\t** ERROR: $args **\n";
print "\tType /help for help\n";
}

# handle login acknowledgement from server
sub login_ack {
my ($code,$nickname) = @_;
print "\tLog in successful. Welcome $nickname.\n";
}

# handle channel join/part messages from server
sub join_part {
my ($code,$msg) = @_;
my ($title,$users) = $msg =~ /^(\S+) (\d+)/;
print $code == JOIN_ACK
? "\tWelcome to the $title Channel ($users users)\n"
: "\tYou have left the $title Channel\n";
}

# handle channel listing messages from server
sub list_channel {
my ($code,$msg) = @_;
my ($title,$count,$description) = $msg =~ /^(\S+) (\d+) (.+)/;
printf "\t%-20s %-40s %3d users\n","[$title]",$description,$count;
}

# handle a public message from server
sub public_msg {
my ($code,$msg) = @_;
my ($channel,$user,$text) = $msg =~ /^(\S+) (\S+) (.*)/;
print "\t$user [$channel]: $text\n";
}

# handle a private message from server
sub private_msg {
my ($code,$msg) = @_;
my ($user,$text) = $msg =~ /^(\S+) (.*)/;
print "\t$user [**private**]: $text\n";
}

# handle user join/part messages from server
sub user_join_part {
my ($code,$msg) = @_;
my $verb = $code == USER_JOINS ? 'has entered' : 'has left';
my ($channel,$user) = $msg =~ /^(\S+) (\S+)/;
print "\t<$user $verb $channel>\n";
}

# handle user listing messages from server
sub list_user {
my ($code,$msg) = @_;
my ($user,$timeon,$channels) = $msg =~ /^(\S+) (\d+) (.+)/;
my ($hrs,$min,$sec) = format_time($timeon);
printf "\t%-15s (on %02d:%02d:%02d) Channels: %s\n",$user,$hrs,$min,$sec,$channels;
}

# nicely formatted time (hr, min sec)
sub format_time {
my $sec = shift;
my $hours = int( $sec/(60*60) );
$sec -= ($hours*60*60);
my $min = int( $sec/60 );
$sec -= ($min*60);
return ($hours,$min,$sec);
}

# print help message
sub do_help {
print <<END;
Commands:
/channels List chat channels
/join <channel> Join a channel
/part <channel> Depart a channel
/users List users in current channel
/public <msg> Send a public message
/private <user> <msg> Send a private message to user
/login Login again
/quit Quit

Typing anything that doesn't begin with a "/" is interpreted as a message
to the current channel.
END
}

END {
if (defined $server) {
$server->send_event(LOGOFF,$nickname);
$server->close;
}
}

[devel]

一个服务端的聊天程序，来自INTERNET。

#!/usr/bin/perl -w
# file: chat_server.pl
# Figure 19.5: Chat server using UDP

use strict;
use ChatObjects::ChatCodes;
use ChatObjects::Comm;
use ChatObjects::User;
use ChatObjects::Channel;
use constant DEBUG => 0;

# create a bunch of channels
ChatObjects::Channel->new('CurrentEvents', 'Discussion of current events');
ChatObjects::Channel->new('Weather', 'Talk about the weather');
ChatObjects::Channel->new('Gardening', 'For those with the green thumb');
ChatObjects::Channel->new('Hobbies', 'For hobbyists of all types');
ChatObjects::Channel->new('Pets', 'For our furry and feathered friends');

# dispatch table
my %DISPATCH = (
LOGOFF() => 'logout',
JOIN_REQ() => 'join',
PART_REQ() => 'part',
SEND_PUBLIC() => 'send_public',
SEND_PRIVATE() => 'send_private',
LIST_CHANNELS() => 'list_channels',
LIST_USERS() => 'list_users',
);

# create the UDP socket
my $port = shift || 2027;
my $server = ChatObjects::Comm->new(LocalPort=>$port);
warn "servicing incoming requests...\n";

while (1) {
next unless my ($code,$msg,$addr) = $server->recv_event;

warn "$code $msg\n" if DEBUG;
do_login($addr,$msg,$server) && next if $code == LOGIN_REQ;

my $user = ChatObjects::User->lookup_byaddr($addr);
$server->send_event(ERROR,"please log in",$addr) && next
unless defined $user;

$server->send_event(ERROR,"unimplemented event code",$addr) && next
unless my $dispatch = $DISPATCH{$code};
$user->$dispatch($msg);
}

sub do_login {
my ($addr,$nickname,$server) = @_;
return $server->send_event(ERROR,"nickname already in use",$addr)
if ChatObjects::User->lookup_byname($nickname);
return unless ChatObjects::User->new($addr,$nickname,$server);
}

[devel]

一个与日期时间服务器相匹配得客户程序。

#!/usr/bin/perl
# file: localtime_cli.pl
# Figure 22.4: localtime_cli.pl, Daytime Client

#load model
use IO::Socket;
use POSIX 'tmpnam';
use Getopt::Long;

#define const
use constant SOCK_PATH => '/tmp/localtime';
use constant TIMEOUT => 1;

my $path;
GetOptions("path=s" => \$path);
$path ||= SOCK_PATH;
my $local = tmpnam();

$SIG{TERM} = $SIG{INT} = sub { exit 0 };

# set umask to be world writable ...create a socket.
umask(0111);
my $sock = IO::Socket::UNIX->new( Type => SOCK_DGRAM,
Local => $local,
) or die "Socket: $!";

my $timezone = shift || ' ';
my $peer = sockaddr_un($path);

#send request and wait reply.
send($sock,$timezone,0,$peer) or die "Couldn't send(): $!";
my $data;
eval {
local $SIG{ALRM} = sub { die "timeout\n" };
alarm(TIMEOUT);
recv($sock,$data,128,0) or die "Couldn't recv(): $!";
alarm(0);
} or die "Couldn't get response: $@";
print $data,"\n";


END { unlink $local if $local }

[azheng]

好东东，谢谢！辛苦啦！

注意：从现在开始，请不要在置顶贴子里闲谈和灌水，谢谢合作！

[KornLee]

from: http://www.linuxsir.org/bbs/showthre...threadid=46381


#!/usr/bin/perl

if ( $#ARGV != 0 ){
printf(STDERR "Usage: perl treedir.pl directory\n");
exit(0);
}

glob $vtab="|";
glob @fmt=();

glob @dirs=();

search_dir($ARGV[0]);

sub listdir{
my ($dirname) = @_;

opendir(DIR_HANDLE, $dirname);
my (@dirlist) = readdir(DIR_HANDLE);

shift(@dirlist);
shift(@dirlist);

closedir(DIR_HANDLE);
return @dirlist;
}

sub getPath{
return join("/",@dirs);
}

sub search_dir{
my ($dirnm)=@_;

push(@dirs,$dirnm); # cd $dirnm
my (@entries)=listdir(getPath());
my ($count)=$#entries;

foreach $file (@entries) {

if (0==$count){
$vtab="\\\\";
}

display($file);
$vtab="|";

if (-d getPath()."/".$file){

if($count==0){
push(@fmt,"\t");
}
else {
push(@fmt,"|\t");
}

search_dir($file);
}

$count--;
}

pop(@fmt);
pop(@dirs); # cd ..
}

sub display{
my ($entry)=@_;
my ($formats)=join("",@fmt);

print $formats.$vtab."-----".$entry."\n";
}


windows linux 下都可使用。
查找的目录级非常大，足够实用。

[KornLee]

from:http://www.linuxsir.org/bbs/showthre...5&pagenumber=3

#!/usr/bin/perl -w

# Chinese count method
# wrote by Lyoo
# iamlyoo@163.com
# 2003/06/22


# match @unit = qw / 个 拾 佰 仟 万 拾万 佰万 仟万/
@unit = qw / A B C D E F G H / ;

##########################################################
#
# receive user's input
#
########################################################

$count = 0;
while ( $count < 1 ) {
print "Please input a number:";
chomp ($number = <STDIN> );
if ( $number =~ /^[-,+]?\d+\.?\d*$/ ) {
$count += 1;
} else {
print "It's not a Number!\n";
redo;
}
}

##########################################################
#
# create a number_array
#
#########################################################

# add a number to the number_string,
# so that the while-loop can get the "0" in the tail of the number_string.
$number_9 = $number."9";

# convert the number to a array.
$dot = "no";
while ($number_9) {
my $single = $number_9;
$single =~ s/([\d,.,+,-]).*/$1/;
$number_9 =~ s/[\d,.,+,-](.*)/$1/;
push (@number_array,$single);
$dot = "yes" if $single eq ".";
}

# delect the addition number.reverse the array.
pop @number_array;
@number_array = reverse @number_array;

# get number's sylobm.
$sylobm = "";
$sylobm = pop @number_array if $number_array[-1] =~ /[+,-]/;

# get the number_dot_string.
$number_dot_string = "";
if ($dot eq "yes") {
while (@number_array) {
$number_dot_string .= shift @number_array;
last if $number_dot_string =~ /\d\./;
};
$number_dot_string = reverse $number_dot_string;
};


#############################################################################
#
# creat a number_unit_array
#
#############################################################################

$min_unit = 9;
$j = 0;
$i = 0;
$n = 0;

foreach (@number_array) {
push (@number_unit_array,$unit[$i].$_);

if ($i == 0) {
$j++;
$min_unit = "on";
$switch = "on"
};

unless ($switch eq "off" || $_ eq "0") {
$min_unit = $n;
};

unless ($switch eq "off" || $min_unit eq "on") {
$number_unit_array[$min_unit] = ("Z" x ($j-1)).$number_unit_array[$min_unit];
$switch = "off";
}

$i++;
$n++;
$i = $i % 8;
}

#############################################################################
#
# modify the number_unit_string
#
#############################################################################

foreach (@number_unit_array) {
$number_unit_string .= $_;
}
$number_unit_string = reverse $number_unit_string;
$_ = $number_unit_string;
s/0[A-H]/0/g;
s/0+/0/g;
s/A//g;
s/0+$//;

#print "$_\n";

s/H(\d)G(\d)F(\d)E/D$1C$2B$3E/g;

s/H(\d)G(\d)F/D$1C$2F/g;
s/H(\d)G(\d)E/D$1C$2E/g;
s/H(\d)F(\d)E/D$1B$2E/g;
s/G(\d)F(\d)E/C$1B$2E/g;


s/H(\d)E/D$1E/g;
s/G(\d)E/C$1E/g;
s/F(\d)E/B$1E/g;

s/H(\d)F/D$1F/g;
s/G(\d)F/C$1F/g;

s/H(\d)G/D$1G/g;

$number_unit_string = "$sylobm"."$_"."$number_dot_string";

#############################################################################
#
# output the number_unit_string as a array
#
#############################################################################

# convert number_unit_string to array.
# it's ugly but without this action
# chinese can't output correct.
# I don't know why

while ($number_unit_string) {
my $single = $number_unit_string;
$single =~ s/([\w,.,+,-]).*/$1/;
$number_unit_string =~ s/[\w,.,+,-](.*)/$1/;
push (@number_unit_ok,$single);
}
#print "number_unit_ok is @number_unit_ok.\n";

foreach (@number_unit_ok) {
&print_chinese;
}
print "\n";

sub print_chinese {
if ($_ eq 0) {
print "零";
} elsif ($_ eq 1) {
print "壹";
} elsif ($_ eq 2) {
print "贰";
} elsif ($_ eq 3) {
print "叁";
} elsif ($_ eq 4) {
print "肆";
} elsif ($_ eq 5) {
print "伍";
} elsif ($_ eq 6) {
print "陆";
} elsif ($_ eq 7) {
print "柒";
} elsif ($_ eq 8) {
print "捌";
} elsif ($_ eq 9) {
print "玖";
} elsif ($_ eq A) {
print "个";
} elsif ($_ eq B) {
print "拾";
} elsif ($_ eq C) {
print "佰";
} elsif ($_ eq D) {
print "仟";
} elsif ($_ eq E) {
print "万";
} elsif ($_ eq F) {
print "拾万";
} elsif ($_ eq G) {
print "佰万";
} elsif ($_ eq H) {
print "仟万";
} elsif ($_ eq Z) {
print "亿";
} elsif ($_ eq "+") {
print "<正>";
} elsif ($_ eq "-") {
print "<负>";
} elsif ($_ eq ".") {
print "<点>";
}
}

#####################################################
# the end of this script
####################################################

[devel]

使用pipe()创建链接的文件句柄。
#!/opt/bin/perl -w

#++
# file: piping-facfib.pl
#
# Slightly modified from
# figure 2.2: (Using pipe() to create linked filehandles)
# in Network Programming With Perl by Lincoln D. Stein
# (c)2001 Addison-Wesley
#--

use POSIX 'WNOHANG'; # for reaper()
use diagnostics;
use strict;
my $arg = shift || 10;

print "piping_facfib.pl\n";
print " This program starts two subprocesses that write to a pipe.\n";
print " The main process reads from the pipe and prints what it receives.\n";
print " Notice the non-deterministic order of the results.";
print "\n";
print " The subprocesses compute the first n Fibronacci and factorials.\n";
print " n is the command line argument, or 10 if no argument is specified.\n";

# prepare to handle CHLD signals when subprocesses exit
$SIG{CHLD} = \&reaper;

pipe(READER,WRITER) or die "Can't open pipe: $!\n";

if (0 == fork) { # first child writes to WRITER
close READER;
select WRITER; # this is what print() will work with
$| = 1; # unbuffered print()-ing
factorial($arg);
exit 0;
}


if (0 == fork) { # second child writes to WRITER
close READER;
select WRITER;
$| = 1;
my $result = fibonacci($arg);
exit 0;
}

# parent process closes WRITER and reads from READER
close WRITER;
print while <READER>;


# -- subroutines start here -- #

sub short_time {
return rand 3;
} # short_time()

sub factorial {
my $target = shift;
my $result = 1;
my $i;
for ($i = 1; $i <= $target; $i++) {
sleep short_time();
$result *= $i;
print "factorial($i) => ",$result, "\n";
}
} # factorial()

sub fibonacci {
my $target = shift;
my $result = 1;
my ($a, $b) = (1,0);
my $i;

for ($i = 1; $i <= $target; $i++) {
$result = $a + $b;
print "fibonacci($i) => ", $result, "\n";
($a, $b) = ($b, $result);
sleep short_time();
}
} # fibonacci()

sub reaper {
while ((my $kid = waitpid(-1, WNOHANG))>0) {
warn "Reaped child process with PID $kid\n";
}
} # reaper()

[devel]

这个程序打开一个文件、统计文件的行数，并报告其发现。
#!/usr/bin/perl -w
#filename: count_lines.pl
use strict; #使用strict检验语法。
use IO::File;
my $file =shift; #退入一个参数，这里指输入一个文件名
my $counter=0;
my $fh=IO::File->new($file) or die "Could not open $file:$!\n"; #用IO::File打开文件并返回一个文件句柄$fh.不成功返回undef,后以一条错误信息终止。
while (defined (my $line=$fh->getline) ) { #在while()循环的测试部分调用了IO::File对象的getline()方法。
$counter++;
}
STDOUT->print("counted $counter line\n"); #从STDOUT读取内容，并发送到printf(),

[devel]

come from internett

#!/usr/bin/perl -w

# popcorn.pl
# A CGI program, written using CGI.pm, to process
# the popcorn sales form
# Initialize total price and total number of purchased items

$total_price = 0;
$total_items = 0;

use CGI ":standard";

# First produce the header part of the HTML return value


print header(-charset=>'UTF-8');
print start_html(-dtd=>[ '-//W3C//DTD XHTML 1.0 Strict//EN',
'http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd' ],
-title=>"CGI-Perl Popcorn Sales Form, using CGI.pm",
-head=>Link({-rel=>'stylesheet', -type=>'text/css', -href=>'../style.css'}));

# Set local variables to the parameter values

my($name, $street, $city, $payment) =
(param("name"), param("street"),
param("city"), param("payment"));
my($unpop, $caramel, $caramelnut, $toffeynut) =
(param("unpop"), param("caramel"),
param("caramelnut"), param("toffeynut"));

# Compute the number of items ordered and the total cost

if ($unpop > 0) {
$cost = 3.0 * $unpop;
$total_price += $cost;
$total_items += $unpop;
}

if ($caramel > 0) {
$cost = 3.5 * $caramel;
$total_price += $cost;
$total_items += $caramel;
}

if ($caramelnut > 0) {
$cost = 4.5 * $caramelnut;
$total_price += $cost;
$total_items += $caramelnut;
}

if ($toffeynut > 0) {
$cost = 5.0 * $toffeynut;
$total_price += $cost;
$total_items += $toffeynut;
}

# Produce the result information to the browser and finish the page

print "<h3>Customer:</h3>\n",
"<p>$name <br />\n", "$street <br />\n", "$city <br />\n",
"Payment method: $payment <br /><br /></p>\n",
"<h3>Items ordered:</h3> \n",
"<p>Unpopped popcorn: $unpop <br /> \n",
"Caramel popcorn: $caramel <br /> \n",
"Caramel nut popcorn: $caramelnut <br /> \n",
"Toffey nut popcorn: $toffeynut <br /><br /> \n",
"You ordered $total_items popcorn items <br />\n",
"Your total bill is: \$ $total_price <br /></p> \n";
print end_html();

[home]

come from internett

#!/usr/local/bin/perl -w
#
# helper script for ck_cov.aml
#
# usage: ck_cov.pl [service] [covname] [textfile] [other argss...]
#
# returns exit status 0 if this prog ran ok; stdout will be '' if
# it found nothing, could be anything (presumably 'ERROR' if it found
# anything wrong with the thing it was checking.
# Only returns exist status != 0 if something went wrong
#
# 08-may-1997 tglover Created
# 08-jun-1997 bmackenz Added keywords to 'missing meta' output.
# 17-jul-1997 tglover Added check for universe polygon labelled
# 21-jul-1997 tglover Added check for unpopulated FCODEs/TAGs
# 05-jun-1998 bmackenz Added counts to check for unpopulated above.
# 12-feb-2001 teglover Sytax correction, line 81 (added parens)

if (@ARGV < 1) {
print STDERR "usage: ck_cov.pl <service> <textfile> <other args>\n";
exit 1;
}

$service = shift;
$service =~ tr/A-Z/a-z/;

$infile = shift;
if (not open( INFILE, "$infile" )) {
print STDERR "Can not open $infile\n";
exit 1;
}

$rtn_val = ''; # this is set by global side effect

# Note that to read parms within the sbrs here, must get them from
# @ARGV instead of @_.

eval "&$service";
##$eval_rtn = eval "&$service( @ARGV )";
##print "eval rtn is [$eval_rtn], \$\@ is [$@]\n";
##print "only running ck_item_pop\n";
##&ck_item_pop( @ARGV );

close( INFILE );

# check for errors here

# exit with the return value
print STDOUT "$rtn_val\n";
exit;

#---------------
# this is passed LIST <cover>.meta KEY
sub ck_meta {
while (<INFILE>) {
if (/^ *[0-9]+ +([A-Z][A-Z0-9_]+)/) {
$keyvals{ $1 } = 1;
}
}
# check for required keys
$missing_keys = "";
foreach $key ('TITLE', 'DESCRIPTION', 'SOURCE', 'ACCURACY') {
if (not exists( $keyvals{ $key })) {
$missing_keys = $missing_keys." ".$key
}
}
if ($missing_keys) {
$rtn_val = "missing meta KEY values: $missing_keys";
}
}
#-------------------
# this is passed (in the file) the name of the cover
# It will test for the user's ability to alter the cover.
sub ck_fix_access {
my( $cov, $wkspace );

# get the workspace & cover names
$_ = <INFILE>; # get full filespec from file
$_ =~ tr/A-Z/a-z/; # lower case
# get the names
if (not (($wkspace, $cov) = (m!^\s*(\S+)/(\S+)\s*$!))) {
$rtn_val = 'internal: cannot parse workspace/cover in ck_fix_access';
return;
}

# does the user have access to the cover dir?
if (not -w "$wkspace/$cov") {
$rtn_val = 'cover is not writable';
# can the user write in the cover's workspace?
} elsif (not -w "$wkspace") {
$rtn_val = 'workspace containing cover is not writable';
# can the user write in the workspace's info dir?
} elsif (not -w "$wkspace/info") {
$rtn_val = 'info directory not writable';
}

}
#-------------------
# this is passed REGIONERRORS
sub ck_regions {
while (<INFILE>) {
if (/^Unclosed region detected/i or /has unclosed ring/) {
$rtn_val = 'failed REGIONERRORS';
last;
}
}
}
#---------------------
# this is passed LABELERRORS then NODEERRORS DANGLE
sub ck_polys {
while (<INFILE>) {
if (/total number of dangling nodes: *([0-9]+)/i and $1 > 0) {
$rtn_val = 'fails NODEERRORS';
last;
}
elsif (/polygon +([0-9]+) +has +([0-9]+) +label/i and
($1 != 1 or $2 != 0)) {
$rtn_val = 'fails LABELERRORS';
last;
}
}
}
#------------------------
# this is passed LABELERRORS then NODEERRORS DANGLE
# It makes sure that the universe poly is NOT labelled
sub ck_universe_label {
$rtn_val = 'fails universe check';
while (<INFILE>) {
if (/polygon +1 +has +0 +label/i) {
# the universe has no label point (this is good)
$rtn_val = '';
last;
}
}
}
#------------------------
#
# This is passed a list of all the <item> values
# args:
# info file (eg AAT, PATNATION, etc)
# item name
# whether the cover contains polygons
# Checks that all the items are populated.
sub ck_item_pop {
my( $filetype, $itemname, $polyflag) = @ARGV;

# the list should contain
# first line: headings (ignore)
# other lines: record# item_value

$numrec = 0;
$unpop = 0;
while (<INFILE>) {
$numrec++ ;
# any line with only one word will be an unpopulated item
if (/^\s*(\S+)\s*$/) {
# only one word... but ok if record one in poly topology
if ($1 eq '1' and $filetype =~ /^pat/i and $polyflag > 0) {
# this is the universe poly -- it's ok to be blank
} else {
$unpop++ ;
}
}
}
if ($unpop > 0) {
$rtn_val = "item $itemname blank ($unpop x of $numrec) in .$filetype";
}

}