| 1 | #!/usr/bin/perl -w |
| 2 | |
| 3 | # |
| 4 | # demo_pl |
| 5 | # |
| 6 | # A "self-extracting archive" for some demo scripts. |
| 7 | # |
| 8 | # hello - the classic |
| 9 | # helloyou - advanced classic |
| 10 | # httpget1 - simple sockets |
| 11 | # httpget2 - simple sockets done complex |
| 12 | # md5 - core extension |
| 13 | # time - system call |
| 14 | # times - more system calls |
| 15 | # |
| 16 | |
| 17 | use strict; |
| 18 | |
| 19 | unless (@ARGV && $ARGV[0] =~ /^(?:list|extract|cleanup)$/) { |
| 20 | die "$0: Usage: $0 [list|extract|cleanup]\n"; |
| 21 | } |
| 22 | |
| 23 | my $action = shift; |
| 24 | my $list = $action eq 'list'; |
| 25 | my $extract = $action eq 'extract'; |
| 26 | my $cleanup = $action eq 'cleanup'; |
| 27 | |
| 28 | my $fh; |
| 29 | while (<DATA>) { |
| 30 | if (/^-- (.+\.pl)$/) { |
| 31 | if ($cleanup) { |
| 32 | print "Deleting $1\n"; |
| 33 | unlink $1 or warn "$0: $1: $!\n"; |
| 34 | } elsif ($extract) { |
| 35 | defined $fh && close($fh); |
| 36 | open($fh, ">$1") or die "$0: '$1': $!\n"; |
| 37 | print "Extracting $1\n"; |
| 38 | } elsif ($list) { |
| 39 | print "$1\n"; |
| 40 | } |
| 41 | } else { |
| 42 | print $fh $_ if $extract; |
| 43 | } |
| 44 | } |
| 45 | defined $fh && close($fh); |
| 46 | exit(0); |
| 47 | __END__ |
| 48 | -- hello.pl |
| 49 | print "hello world!\n"; |
| 50 | -- helloyou.pl |
| 51 | print "What is your name?\n"; |
| 52 | chomp(my $name = <STDIN>); |
| 53 | print "Hello, $name!\n"; |
| 54 | print "Amazing fact #1:\n"; |
| 55 | printf "Your name has\n%d character%s!\n", |
| 56 | length($name), length($name) == 1 ? "" : "s"; |
| 57 | print "Amazing fact #2:\n"; |
| 58 | printf "Your name is\n%s backwards!\n", scalar reverse $name; |
| 59 | -- httpget1.pl |
| 60 | print "(Using plain sockets)\n"; |
| 61 | use Socket; |
| 62 | print "Host? "; |
| 63 | my $host = <STDIN>; |
| 64 | chomp($host); |
| 65 | $host = 'www.nokia.com' unless length $host; |
| 66 | my $port = 80; |
| 67 | my $iaddr = inet_aton($host) || die "no host: $host"; |
| 68 | my $paddr = sockaddr_in($port, $iaddr); |
| 69 | my $proto = getprotobyname("tcp"); |
| 70 | socket(S, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; |
| 71 | connect(S, $paddr) || die "connect: $!"; |
| 72 | print "$host:$port:\nConnected.\n"; |
| 73 | select(S); $| = 1; select(STDOUT); |
| 74 | print S "GET / HTTP/1.0\012\012" || die "GET /: $!"; |
| 75 | my @line; |
| 76 | print "Receiving...\n"; |
| 77 | while (my $line = <S>) { |
| 78 | push @line, $line; |
| 79 | } |
| 80 | close(S) || die "close: $!"; |
| 81 | printf "Got %d lines.\n", scalar @line; |
| 82 | -- httpget2.pl |
| 83 | use IO::Socket; |
| 84 | print "(Using IO::Socket)\n"; |
| 85 | print "Host? "; |
| 86 | my $host = <STDIN>; |
| 87 | chomp($host); |
| 88 | $host = 'www.nokia.com' unless length $host; |
| 89 | my $port = 80; |
| 90 | my $remote = |
| 91 | IO::Socket::INET->new(Proto => "tcp", |
| 92 | PeerAddr => $host, |
| 93 | PeerPort => $port); |
| 94 | print "$host:$port:\nConnected.\n"; |
| 95 | select($remote); $| = 1; select(STDOUT); |
| 96 | print $remote "GET / HTTP/1.0\012\012" || die "GET /: $!"; |
| 97 | my @line; |
| 98 | print "Receiving...\n"; |
| 99 | while (my $line = <$remote>) { |
| 100 | push @line, $line; |
| 101 | } |
| 102 | close($remote) || die "close: $!"; |
| 103 | printf "Got %d lines.\n", scalar @line; |
| 104 | -- md5.pl |
| 105 | use Digest::MD5 'md5_hex'; |
| 106 | print "(Using Digest::MD5)\nMD5 of 'Perl' is:\n"; |
| 107 | print md5_hex('Perl'), "\n"; |
| 108 | -- time.pl |
| 109 | print "Running in $^O\n"; |
| 110 | print scalar localtime, "\n"; |
| 111 | -- times.pl |
| 112 | use Time::HiRes qw(time sleep); |
| 113 | print CORE::time(), "\n"; |
| 114 | print "Hires\n"; |
| 115 | print time(), "\n"; |
| 116 | print "Sleep 1.5 s...\n"; |
| 117 | sleep(1.5); |
| 118 | print time(), "\n"; |
| 119 | print "To one million...\n"; |
| 120 | my $t0 = time(); |
| 121 | print $t0, "\n"; |
| 122 | print "Cpu ", scalar times(), "\n"; |
| 123 | for(my $i = 0; $i < 1e6; $i++) {} |
| 124 | print "Cpu ", scalar times(), "\n"; |
| 125 | my $t1 = time(); |
| 126 | print $t1, "\n"; |
| 127 | print "Wall ", $t1 - $t0, "\n"; |
| 128 | |