Programming with Perl | Cookie Monsters (Web Techniques, May 2001)

1    #!/usr/bin/perl -Tw
2    use strict;
3    $|++;
4    
5    use CGI qw(:all);
6    
7    ## cookie check
8    my $browser = cookie("browser");
9    if (defined $browser) {         # got a good browser
10      Delete("_cookiecheck");       # don't let this leak further
11    } else {                        # no cookie? set one
12      require MD5;
13      my $cookie = cookie
14        (-name => 'browser',
15         -value => MD5->hexhash(MD5->hexhash(time.{}.rand().$$)));
16    
17      if (defined param("_cookiecheck")) { # already tried!
18        print +(header(-cookie => $cookie),
19                start_html("Missing cookies"),
20                h1("Missing cookies"),
21                p("This site requires a cookie to be set. Please permit this."),
22                startform, submit("OK"), endform,
23                end_html);
24      } else {
25        param("_cookiecheck", 1);   # prevent infinite loop
26        print redirect (-cookie => $cookie, -uri => self_url());
27      }
28      exit 0;
29    }
30    
31    ## At this point, $browser is now the unique ID of the browser
32    
33    require File::Cache;
34    my $cache = File::Cache->new({namespace => 'cookiemaker',
35                                  username => 'nobody',
36                                  filemode => 0666,
37                                  expires_in => 3600, # one hour
38                                 });
39    
40    ## first, some housekeeping
41    unless ($cache->get(" _purge_ ")) {
42      $cache->purge;                # remove expired objects
43      $cache->set(" _purge_ ", 1, 3600 * 4); # purge every four hours
44    }
45    
46    my $user = $cache->get($browser); ## either the logged-in user, or undef
47    
48    print header,start_html('session demonstration'),h1('session demonstration');
49    
50    ## handle requested transitions (login or logout)
51    if (defined $user and defined param("_logout")) {
52      Delete("_logout");
53      $cache->remove($browser);
54      print p("You are no longer logged in as $user.");
55      undef $user;
56    } elsif (not defined $user and defined (my $try_user = param("_user"))) {
57      Delete("_user");
58      my $try_password = param("_password");
59      Delete("_password");
60      if ($try_user =~ /\A\w+\z/ and verify($try_user, $try_password)) 		{
61        $user = $try_user;
62        print p("Welcome back, $user.");
63      } else {
64        print p("I'm sorry, that's not right.");
65      }
66    }
67    
68    ## handle current state (possibly after transition)
69    if (defined $user) {
70      $cache->set($browser,$user);  # update cache on each hit
71      print p("You are logged in as $user.");
72      print startform, hidden("_logout", 1), submit("Log out"), endform;
73    } else {
74      print p("You are not logged in.");
75      print
76        startform,
77          table({-border => 1, -cellspacing => 0, -cellpadding => 2},
78                Tr(th("username:"),
79                   td(textfield("_user")),
80                   td({-rowspan => 2}, submit("login"))),
81                Tr(th("password:"), td(password_field("_password")))),
82                  endform;
83    }
84    
85    ## rest of page would go here, paying attention to $user
86    
87    for ([Cookies => \&cookie], [Params => \¶m]) {
88      my ($title, $f) = @$_;
89    
90      print h2($title), table 
91        ({-border => 0, -cellspacing => 0, -cellpadding => 2},
92         map (Tr(th(escapeHTML($_)), td(escapeHTML(join ", ", $f->($_)))),
93            $f->()));
94    }
95    
96    ## sample verification
97    
98    sub verify {
99      my($user, $password) = @_;
100      return index($password, $user) > -1; # require password to contain user
101    }