Perl_save_alloc can use the new(er) SSGROW rather than looping.

[perl5.git] / symbian / demo_pl

#!/usr/bin/perl -w

#
# demo_pl
#
# A "self-extracting archive" for some demo scripts.
#
# hello		- the classic
# helloyou	- advanced classic
# httpget1	- simple sockets
# httpget2	- simple sockets done complex
# md5		- core extension
# time		- system call
# times		- more system calls
#

use strict;

unless (@ARGV && $ARGV[0] =~ /^(?:list|extract|cleanup)$/) {
   die "$0: Usage: $0 [list|extract|cleanup]\n";
}

my $action = shift;
my $list    = $action eq 'list';
my $extract = $action eq 'extract';
my $cleanup = $action eq 'cleanup';

my $fh;
while (<DATA>) {
   if (/^-- (.+\.pl)$/) {
      if ($cleanup) {
         print "Deleting $1\n";
         unlink $1 or warn "$0: $1: $!\n";
      } elsif ($extract) {
        defined $fh && close($fh);
        open($fh, ">$1") or die "$0: '$1': $!\n";
        print "Extracting $1\n";
      } elsif ($list) {
        print "$1\n";
      }
   } else {
      print $fh $_ if $extract;
   }
}
defined $fh && close($fh);
exit(0);
__END__
-- hello.pl
print "hello world!\n";
-- helloyou.pl
print "What is your name?\n";
chomp(my $name = <STDIN>);
print "Hello, $name!\n";
print "Amazing fact #1:\n";
printf "Your name has\n%d character%s!\n",
       length($name), length($name) == 1 ? "" : "s";
print "Amazing fact #2:\n";
printf "Your name is\n%s backwards!\n", scalar reverse $name;
-- httpget1.pl
print "(Using plain sockets)\n";
use Socket;
print "Host? ";
my $host = <STDIN>;
chomp($host);
$host = 'www.nokia.com' unless length $host;
my $port    = 80;
my $iaddr   = inet_aton($host)           || die "no host: $host";
my $paddr   = sockaddr_in($port, $iaddr);
my $proto   = getprotobyname("tcp");
socket(S, PF_INET, SOCK_STREAM, $proto)  || die "socket: $!";
connect(S, $paddr)                       || die "connect: $!";
print "$host:$port:\nConnected.\n";
select(S); $| = 1; select(STDOUT);
print S "GET / HTTP/1.0\012\012"         || die "GET /: $!";
my @line;
print "Receiving...\n";
while (my $line = <S>) {
    push @line, $line; 
}
close(S)                                 || die "close: $!";
printf "Got %d lines.\n", scalar @line;
-- httpget2.pl
use IO::Socket;
print "(Using IO::Socket)\n";
print "Host? ";
my $host = <STDIN>;
chomp($host);
$host = 'www.nokia.com' unless length $host;
my $port = 80;
my $remote =
    IO::Socket::INET->new(Proto    => "tcp",
                          PeerAddr => $host,
                          PeerPort => $port);
print "$host:$port:\nConnected.\n";
select($remote); $| = 1; select(STDOUT);
print $remote "GET / HTTP/1.0\012\012" || die "GET /: $!";
my @line;
print "Receiving...\n";
while (my $line = <$remote>) {
    push @line, $line; 
}
close($remote)                         || die "close: $!";
printf "Got %d lines.\n", scalar @line;
-- md5.pl
use Digest::MD5 'md5_hex';
print "(Using Digest::MD5)\nMD5 of 'Perl' is:\n";
print md5_hex('Perl'), "\n";
-- time.pl
print "Running in $^O\n";
print scalar localtime, "\n";
-- times.pl
use Time::HiRes qw(time sleep);
print CORE::time(), "\n";
print "Hires\n";
print time(), "\n";
print "Sleep 1.5 s...\n";
sleep(1.5);
print time(), "\n";
print "To one million...\n";
my $t0 = time();
print $t0, "\n";
print "Cpu  ", scalar times(), "\n";
for(my $i = 0; $i < 1e6; $i++) {}
print "Cpu  ", scalar times(), "\n";
my $t1 = time();
print $t1, "\n";
print "Wall ", $t1 - $t0, "\n";