view release on metacpan or  search on metacpan

socialcalc/socialcalcserver.pl  view on Meta::CPAN

   my $jsdir = "/sgi/scjs/"; # The subdirectory of the server home page (when run thru CGI)
                                 # where the .js files are, and ./images/ subdirectory.
   my $imagedir = "/images/sc-";

#
# This whole first section lets this code run either as a CGI script on a server
# or standalone on the desktop run from the Perl command line.
#
# The main processing starts with process_request.
#

   if ($ENV{REQUEST_METHOD}) { # being run as a CGI on a server
     print "Content-type: text/html\n\n";
      my $q = new CGI;
      print process_request($q);
      exit;
      }

   # running locally - do mini-server

   my $d = HTTP::Daemon->new (
                    LocalPort => 6557,
                    Reuse => 1);

   if (!$d) {
      print "simpleedit could not start on 127.0.0.1:6557\n";
      exit;
      }

   print "socialcalcserver\nAccess at: http://127.0.0.1:6557/\n";

   while (my $c = $d->accept) {

      # Make sure the request is from our machine

      if ($c) {
         my ($port, $host) = sockaddr_in(getpeername($c));
         if ($host ne inet_aton("127.0.0.1")) {
            $c->close;  # no - ignore request completely
            undef($c);
            next;
            }
         }

      # Process the request

      while ((defined $c) && (my $r = $c->get_request)) {
         if ($r->method eq 'POST' || $r->method eq 'GET') {
            $c->force_last_request;
            my $uri = $r->uri;
            if ($uri =~ /favicon/) {   # if this is a request for favicon.ico, ignore
               $c->send_error(RC_NOT_FOUND);
               next;
               }
            if ($uri =~ /\/quit$/) {
               $c->send_file_response("quitmessage.html");
               $c->close;
               undef($c);
               exit;
               }
            if ($uri =~ /\/([a-z\-0-9]+)\.(gif|js|css|png)(\?.*)*$/) { # ok request
               $uri = "$1.$2";
               $uri = "images/$uri" if ($2 eq "gif" || $2 eq "png");
#               if ($2 eq "js") {
#                  $res->content_type("text/html; charset=UTF-8");
#                  }
               $c->send_file_response($uri);
               next;
               }

            my $resp="";
            if ($r->method eq 'POST') {
               my $q = new CGI($r->content());
               $resp = process_request($q)
               }
            else {
               my $q = new CGI($r->uri->query());
               $resp = process_request($q)
               }
            my $res = new HTTP::Response(200);
            $res->content_type("text/html; charset=UTF-8");
            $res->expires("-1d");
            $res->content($resp);
            $c->send_response($res);
            }

         else {
            $c->send_error(RC_FORBIDDEN);
            }
         }

      $c->close;
      undef($c);
      }

#
# Main routine starts here:
#

sub process_request {

   my ($request) = @_;
   my $q = new CGI($request);

   my $response;

   my ($statusmessage);

   if (-e $settingsfile) {
      open (SETTINGSFILE, $settingsfile);
      while (my $line = <SETTINGSFILE>) {
         chomp $line; $line =~ s/\r//g;
         my @sline = split /\:/, $line;
         $datadir = $sline[1] if ($sline[0] eq "datadir");
         $jsdir = $sline[1] if ($sline[0] eq "jsdir");
         }
      close SETTINGSFILE;
      }
   else {
      if ($q->param('setup')) { # got settings - do this once
         $datadir = $q->param('datadir');
         $jsdir = $q->param('jsdir');
         open (SETTINGSFILE, ">$settingsfile");