Listing One



1     #!/usr/bin/perl -T
2     use strict;
3     $|++;
4     use lib "/home/merlyn/CGIA";
5     use CGI qw(standard);
6     
7     my $target_dir = "/home/merlyn/public_html/protected";
8     my $target_url = "http://www.teleport.com/~merlyn/protected";
9     my $target_htpasswd = "$target_dir/.htpasswd";
10    my $N = "\n";                   # two chars instead of 4 :-)
11    
12    print
13      header, $N,
14      start_html('subscribe to protected', 'merlyn@stonehenge.com'), $N;
15    
16    unless (param) {                # generate initial form
17      print +
18        h1 ('Subscribe to "protected"'), $N,
19        hr, $N,
20        start_form('POST',url), $N,
21        p, 'Your desired username: ', textfield('username','',20), $N,
22        p, 'Your email address: ', textfield('email','',60), $N,
23        p, 'Your real name: ', textfield('real','',60), $N,
24        p, submit, $N,
25        end_form, $N,
26        hr, $N,
27        end_html, $N;
28      exit 0;
29    }
30    
31    ## main toplevel:
32    eval {
33      my $field_username = param('username');
34      die "BACK: Username must be lowercase alphabetic!\n"
35        unless $field_username =~ /^[a-z]+$/;
36    
37      my $field_email = param('email');
38      die "BACK: Your email address must be non-empty!\n"
39        unless $field_email =~ /\S/;
40    
41      my $field_real = param('real');
42      die "BACK: Your real name must be non-empty!\n"
43        unless $field_real =~ /\S/;
44    
45      ## fields are authenticated, so now lets try to add...
46      open PW, "+>>$target_htpasswd" or
47        die "Cannot attach to $target_htpasswd: $!";
48      flock PW, 2;                  # wait for exclusive lock
49      ## begin critical region (only one proc at a time gets past here)
50    
51      ## first, ensure that we don't have a duplicate username
52      seek PW, 0, 0;                # beginning of file
53      while (<PW>) {
54        my ($user) = split ":";
55        die "BACK: sorry, that username is already taken\n"
56          if $user eq $field_username;
57      }
58      ## good name, so add it
59      seek PW, 0, 2;                # end of file
60      my $password = &random_password;
61      print PW
62        join (":", $field_username, crypt($password,"aa")), "\n";
63      &send_password($field_email, $field_username, $password);
64      &record_user($field_email, $field_username, $field_real);
65      close PW;
66      ## end critical region
67      print +
68        h1("You've been added!"), $N,
69        p, "You've been added! Your password is arriving in email!", $N,
70        end_html;
71      exit 0;
72    };
73    if ($@) {                       # somebody died
74      if ($@ =~ /^BACK: (.*)/) {    # one of our BACK errors?
75        print +
76          h1('Form entry error'), $N,
77          p, $1, $N;
78      } else {                      # nope, an internal error
79        $_ = $@;
80        s/&/&amp;/g;
81        s/</&lt;/g;
82        s/>/&gt;/g;
83        print +
84          h1('Form entry INTERNAL error'), $N,
85          p, 'The error message was ', $N,
86          code(pre($_)), $N;
87      }
88      print
89        p, 'Go back and try again!', $N,
90        end_html, $N;
91      exit 0;
92    }
93    
94    sub random_password {
95      "password";
96    }
97    
98    sub send_password {
99      my ($email, $user, $pass) = @_;
100   }
101   
102   sub record_user {
103     my ($email, $user, $real) = @_;
104   }