t/mock-daemon.pl

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 package HTTP::Daemon::MockClient;
   7
   8 use HTTP::Daemon;
   9 use base qw(HTTP::Daemon::ClientConn);
  10
  11 use HTTP::Status qw(:constants);
  12 use Params::Util qw(_ARRAY _STRING);
  13
  14 my %documents = (
  15     "/etc/passwd" => [
  16                        "root:x:0:0:root:/root:/bin/sh", "daemon:x:1:1:daemon:/usr/sbin:/bin/sh",
  17                        "bin:x:2:2:bin:/bin:/bin/sh"
  18                      ],
  19     "/etc/fstab" => [
  20                       "# <file system> <mount point>   <type>  <options>       <dump>  <pass>",
  21                       "proc            /proc           proc    nodev,noexec,nosuid 0       0",
  22                       "/dev/sda1       /               ext2    defaults        0       0",
  23                       "/dev/sdb1       /data           ext2    defaults        0       0",
  24                       "none            /tmp            tmpfs   defaults,noatime        0       0",
  25                     ],
  26     "/etc/master.passwd"  => "/etc/master.passwd",
  27     "/var/run/dmesg.boot" => [
  28         '[    0.000000] Initializing cgroup subsys cpuset',
  29         '[    0.000000] Initializing cgroup subsys cpu',
  30         '[    0.000000] Linux version 2.6.32-41-generic (buildd@allspice) (gcc version 4.4.3 (Ubuntu 4.4.3-4ubuntu5.1) ) #94-Ubuntu SMP Fri Jul 6 18:00:34 UTC 2012 (Ubuntu 2.6.32-41.94-generic 2.6.32.59+drm33.24)'
  31     ],
  32     "/var/log/messages" => "/var/run/dmesg.boot",
  33 );
  34
  35 sub respond_text_content
  36 {
  37     my ( $c, @cnt ) = @_;
  38     my $resp = HTTP::Response->new(HTTP_OK);
  39     $resp->header( "Content-Type", "text/plain" );
  40     $resp->content( join( "\n", @cnt ) );
  41     $c->send_response($resp);
  42 }
  43
  44 sub handle_httpd_get
  45 {
  46     my ( $c, $req ) = @_;
  47     my $p = $req->uri()->path();
  48     if ( exists( $documents{$p} ) )
  49     {
  50         if ( _ARRAY( $documents{$p} ) )
  51         {
  52             $c->respond_text_content( @{ $documents{$p} } );
  53         }
  54         elsif ( _STRING( $documents{$p} ) )
  55         {
  56             my $tgt = $documents{$p};
  57             if ( $p eq $tgt )
  58             {
  59                 $c->send_error(HTTP_I_AM_A_TEAPOT);
  60                 $c->send_crlf;
  61                 return 0 - HTTP_I_AM_A_TEAPOT;
  62             }
  63             else
  64             {
  65                 $c->send_redirect( $tgt, HTTP_TEMPORARY_REDIRECT );
  66                 $c->send_crlf;
  67             }
  68         }
  69         else
  70         {
  71             $c->send_error(HTTP_FORBIDDEN);
  72             $c->send_crlf;
  73         }
  74     }
  75     else
  76     {
  77         $c->send_error(HTTP_NOT_FOUND);
  78         $c->send_crlf;
  79     }
  80
  81     return 0;
  82 }
  83
  84 package main;
  85
  86 use Getopt::Long;
  87
  88 use HTTP::Daemon;
  89 use HTTP::Status qw(:constants);
  90
  91 my %opts = ();
  92 GetOptions( "httpd-opts=s%" => \%opts );
  93
  94 my $d = HTTP::Daemon->new(%opts);
  95
  96 print "Please to meet you at: <URL:", $d->url, ">\n";
  97 open( STDOUT, $^O eq 'VMS' ? ">nl: " : ">/dev/null" );
  98
  99 my $go = 1;
 100 while ( $go and my $c = $d->accept("HTTP::Daemon::MockClient") )
 101 {
 102     while ( my $r = $c->get_request )
 103     {
 104         my $func = lc( "handle_httpd_" . $r->method );
 105         if ( $c->can($func) )
 106         {
 107             0 == $c->$func($r) or $go = 0;
 108         }
 109         else
 110         {
 111             $c->send_error(HTTP_METHOD_NOT_ALLOWED);
 112         }
 113     }
 114     $c = undef;    # close connection
 115 }
 116 $opts{hdf} or print STDERR "HTTP Server terminated\n";
 117 exit;
 118