Land the mod_perl branch.

webtools/litmus/Litmus.pm

@@ -25,6 +25,7 @@
  # Contributor(s):
  #   Chris Cooper <ccooper@deadsquid.com>
  #   Zach Lipton <zach@zachlipton.com>
+ #   Max Kanat-Alexander <mkanat@bugzilla.org>
  #
  # ***** END LICENSE BLOCK *****
 
@@ -38,40 +39,71 @@ use strict;
 
 use Litmus::Template;
 use Litmus::Config;
+use Litmus::Error;
 use Litmus::Auth;
 use Litmus::CGI;
 
-BEGIN {
+our $_request_cache = {};
+
+# each cgi _MUST_ call Litmus->init() prior to doing anything else.
+# init() ensures that the installation has not been disabled, deals with pending 
+# login requests, and other essential tasks.
+sub init() {
 	if ($Litmus::Config::disabled) {
   	  	my $c = new CGI();
     	print $c->header();
     	print "Litmus has been shutdown by the administrator. Please try again later.";
     	exit;
 	}
-}
-
-# Global Template object
-my $_template;
-sub template() {
-    my $class = shift;
-    $_template ||= Litmus::Template->create();
-    return $_template;
-}
-
-# Global CGI object
-my $_cgi;
-sub cgi() {
-    my $class = shift;
-    $_cgi ||= Litmus::CGI->new();
-    return $_cgi;
-}
-
-# hook to handle a login in progress for any CGI script:
-BEGIN {
+	# check for pending logins:
 	my $c = cgi();
 	if ($c->param("login_type")) {
 		Litmus::Auth::processLoginForm();
 	}
 }
 
+# Global Template object
+sub template() {
+    my $class = shift;
+    request_cache()->{template} ||= Litmus::Template->create();
+    return request_cache()->{template};
+}
+
+# Global CGI object
+sub cgi() {
+    my $class = shift;
+    request_cache()->{cgi} ||= new Litmus::CGI();
+    return request_cache()->{cgi};
+}
+
+sub getCurrentUser {
+	return Litmus::Auth::getCurrentUser();
+}
+
+# cache of global variables for a single request only
+# use me like: Litmus->request_cache->{'var'} = 'foo';
+# entries here are guarenteed to get flushed when the request ends, 
+# even when running under mod_perl
+# from Bugzilla.pm:
+sub request_cache {
+    if ($ENV{MOD_PERL}) {
+        my $request = Apache->request();
+        my $cache = $request->pnotes();
+        # Sometimes mod_perl doesn't properly call DESTROY on all
+        # the objects in pnotes(), so we register a cleanup handler
+        # to make sure that this happens.
+        if (!$cache->{cleanup_registered}) {
+             $request->push_handlers(PerlCleanupHandler => sub {
+                 my $r = shift;
+                 foreach my $key (keys %{$r->pnotes}) {
+                     delete $r->pnotes->{$key};
+                 }
+             });
+             $cache->{cleanup_registered} = 1;
+        }
+        return $cache;
+    }
+    return $_request_cache;
+}
+
 1;

webtools/litmus/Litmus/Auth.pm

@@ -39,12 +39,10 @@ use strict;
 ## header so that any required cookies can be sent.
 
 require Exporter;
-use Litmus;
-use Litmus::DB::User;
 use Litmus::Error;
-use Litmus::Template;
 use Time::Piece;
 use Time::Seconds;
+use Litmus::DB::User;
 
 use CGI;
 
@@ -54,8 +52,6 @@ our @EXPORT = qw();
 my $logincookiename = $Litmus::Config::user_cookiename;
 my $cookie_expire_days = 7;
 
-my $curSession;
-
 # Given a username and password, validate the login. Returns the 
 # Litmus::DB::User object associated with the username if the login 
 # is sucuessful. Returns false otherwise.
@@ -139,7 +135,9 @@ sub getCurrentSession() {
 	
 	# we're actually processing the login form right now, so the cookie hasn't
 	# been sent yet...
-	if ($curSession) { return $curSession } 
+	if (Litmus->request_cache->{'curSession'}) { 
+		return Litmus->request_cache->{'curSession'}; 
+	} 
 	
 	my $sessionCookie = $c->cookie($logincookiename);
   	if (! $sessionCookie) {
@@ -383,7 +381,7 @@ sub makeSession {
                                              sessioncookie => $sessioncookie,
                                              expires => $expires});
   
-  $curSession = $session;
+  Litmus->request_cache->{'curSession'} = $session;
   return $session;
 }
 

webtools/litmus/Litmus/DB/Subgroup.pm

@@ -36,7 +36,7 @@ use strict;
 use base 'Litmus::DBI';
 
 use Time::Piece::MySQL;
-use Litmus::DB::Testresult;
+#use Litmus::DB::Testresult;
 
 Litmus::DB::Subgroup->table('subgroups');
 

webtools/litmus/Litmus/DB/Testcase.pm

@@ -36,9 +36,9 @@ use strict;
 use base 'Litmus::DBI';
 
 use Date::Manip;
-use Litmus::DB::Testresult;
+#use Litmus::DB::Testresult;
 use Memoize;
-use Litmus::Error;
+#use Litmus::Error;
 
 our $default_relevance_threshold = 1.0;
 our $default_match_limit = 25;

webtools/litmus/Litmus/DB/Testresult.pm

@@ -83,7 +83,7 @@ Litmus::DB::Testresult->set_sql(DefaultTestResults => qq{
     SELECT tr.testresult_id,tr.testcase_id,t.summary,tr.submission_time AS created,p.name AS platform_name,pr.name as product_name,trsl.name AS result_status,trsl.class_name result_status_class,b.name AS branch_name,tg.name AS test_group_name, tr.locale_abbrev, u.email
     FROM test_results tr, testcases t, platforms p, opsyses o, branches b, products pr, test_result_status_lookup trsl, testgroups tg, subgroups sg, users u, testcase_subgroups tcsg, subgroup_testgroups sgtg
     WHERE tr.testcase_id=t.testcase_id AND tr.opsys_id=o.opsys_id AND o.platform_id=p.platform_id AND tr.branch_id=b.branch_id AND b.product_id=pr.product_id AND tr.result_status_id=trsl.result_status_id AND tcsg.testcase_id=tr.testcase_id AND tcsg.subgroup_id=sg.subgroup_id AND sg.subgroup_id=sgtg.subgroup_id AND sgtg.testgroup_id=tg.testgroup_id AND tr.user_id=u.user_id AND tr.valid=1
-    ORDER BY tr.submission_time DESC
+    ORDER BY tr.submission_time DESC, t.testcase_id DESC
     LIMIT $_num_results_default 
 });
 

webtools/litmus/Litmus/DBI.pm

@@ -32,20 +32,21 @@
 
 package Litmus::DBI;
 
+require Apache::DBI;
 use strict;
 use warnings;
 use Litmus::Config;
-use Litmus::Error;
 use Memoize;
 
 use base 'Class::DBI::mysql';
 
-my $dsn = "dbi:mysql:$Litmus::Config::db_name:$Litmus::Config::db_host";
+our $dsn = "dbi:mysql:database=$Litmus::Config::db_name;host=$Litmus::Config::db_host;port=3306";
+
+
 
 our %column_aliases;
 
-Litmus::DBI->set_db('Main',
-                         $dsn,
+Litmus::DBI->connection( $dsn,
                          $Litmus::Config::db_user,
                          $Litmus::Config::db_pass,
                          	{AutoCommit=>1}
@@ -90,7 +91,7 @@ sub AUTOLOAD {
     
     my $col = $self->find_column($name);
     if (!$col) {
-        internalEror("tried to call Litmus::DBI method $name which does not exist");
+        internalError("tried to call Litmus::DBI method $name which does not exist");
     }
     
     return $self->$col(@args);
@@ -101,5 +102,29 @@ sub _croak {
 	internalError($message);
 	return;
 }
+
+# Get Class::DBI's default dbh options
+my $db_options = { __PACKAGE__->_default_attributes };
+
+__PACKAGE__->_remember_handle('Main'); # so dbi_commit works
+
+# override default to avoid using Ima::DBI closure
+sub db_Main {
+   my $dbh;
+   if ( $ENV{'MOD_PERL'} and !$Apache::ServerStarting ) {
+	   $dbh = Apache->request()->pnotes('dbh');
+   }
+   if ( !$dbh ) {
+	   $dbh = DBI->connect(
+		   $dsn,  $Litmus::Config::db_user,
+		   $Litmus::Config::db_pass, $db_options
+	   );
+	   if ( $ENV{'MOD_PERL'} and !$Apache::ServerStarting ) {
+		   Apache->request()->pnotes( 'dbh', $dbh );
+	   }
+   }
+   return $dbh;
+}
+
 1;
 

webtools/litmus/Litmus/Error.pm

@@ -36,8 +36,6 @@ package Litmus::Error;
 
 use strict;
 
-use Litmus;
-
 our @ISA = qw(Exporter);
 @Litmus::Error::EXPORT = qw(
 	basicError

webtools/litmus/Litmus/Template.pm

@@ -64,7 +64,7 @@ sub getTemplateIncludePath () {
 }
 
 # Constants:
-my %constants;
+my %constants = {};
 $constants{litmus_version} = $Litmus::Config::version;
 
 # html tag stripper:
@@ -189,17 +189,17 @@ sub create {
     });
 }
 
-# override the process() method to sneak defaultemail into all templates' 
+# override the process() method to sneak defaultemail into all template 
 # variable spaces
 sub process {
 	my ($self, $template, $vars, $outstream, @opts) = @_;
 	my %vars = %$vars;
 	
 	$vars{defaultemail} = $vars{defaultemail} ? $vars{defaultemail} : 
-		Litmus::Auth::getCurrentUser();
+		Litmus->getCurrentUser();
 	
-	$vars{show_admin} = Litmus::Auth::getCurrentUser() ? 
-	  Litmus::Auth::getCurrentUser()->is_admin() : 0;
+	$vars{show_admin} = Litmus->getCurrentUser() ? 
+	  Litmus->getCurrentUser()->is_admin() : 0;
 	
 	$self->SUPER::process($template, \%vars, $outstream, @opts);
 }

webtools/litmus/Litmus/XML.pm

@@ -31,6 +31,10 @@
 
 package Litmus::XML; 
 
+# Litmus XML Interface
+# For further details, see the web services specification at 
+# http://wiki.mozilla.org/Litmus:Web_Services
+
 use strict;
 
 use XML::XPath;
@@ -41,6 +45,8 @@ use Litmus::UserAgentDetect;
 use Date::Manip;
 
 use CGI::Carp qw(set_message fatalsToBrowser);
+
+# if we die for some reason, make sure we give a fatal error per spec
 BEGIN { 
 	set_message(sub { 
 		print "Fatal error: internal server error\n";

webtools/litmus/advanced_search.cgi

@@ -38,17 +38,18 @@ use Litmus::FormWidget;
 use CGI;
 use Time::Piece::MySQL;
 
+Litmus->init();
 my $c = Litmus->cgi();
 print $c->header();
 
-use diagnostics;
+
 
 # Hash refs for maintaining state in the search form.
-my $defaults;
-my $order_bys;
+my $defaults = undef;
+my $order_bys = undef;
 
-our $MAX_SORT_FIELDS = 10;
-our $MAX_SEARCH_FIELDS = 10;
+my $MAX_SORT_FIELDS = 10;
+my $MAX_SEARCH_FIELDS = 10;
 
 my $criteria = "Custom<br/>";
 my $results;
@@ -58,6 +59,7 @@ my $limit;
 my $where_criteria = "";
 my $order_by_criteria = "";
 my $limit_criteria = "";
+
 if ($c->param) {    
 
     foreach my $param ($c->param) {

webtools/litmus/common_results.cgi

@@ -35,12 +35,12 @@ use Litmus::Auth;
 use Litmus::Error;
 use Litmus::DB::Testresult;
 use Litmus::FormWidget;
-use diagnostics;
+
 
 use CGI;
 use Time::Piece::MySQL;
 
-
+Litmus->init();
 my $c = Litmus->cgi();
 print $c->header();
 

webtools/litmus/edit_users.cgi

@@ -32,6 +32,7 @@ use Litmus::Utils;
 use CGI;
 use Time::Piece::MySQL;
 
+Litmus->init();
 my $c = Litmus->cgi(); 
 
 # obviously, you need to be an admin to edit users...

webtools/litmus/enter_test.cgi

@@ -33,6 +33,7 @@ use CGI;
 use Time::Piece::MySQL;
 use Date::Manip;
 
+Litmus->init();
 my $c = Litmus->cgi(); 
 
 # for the moment, you must be an admin to enter tests:

webtools/litmus/index.cgi

@@ -39,10 +39,11 @@ use Litmus::Error;
 use Litmus::DB::Testresult;
 use Litmus::FormWidget;
 
-use CGI;
 use Time::Piece::MySQL;
 
-use diagnostics;
+
+
+Litmus->init();
 
 my ($criteria,$results) = Litmus::DB::Testresult->getDefaultTestResults;
 

webtools/litmus/json.cgi

@@ -38,6 +38,7 @@ use JSON;
 use CGI;
 use Date::Manip;
 
+Litmus->init();
 my $c = Litmus->cgi(); 
 print $c->header('text/plain');
 

webtools/litmus/login.cgi

@@ -33,8 +33,10 @@ $|++;
 use Litmus;
 use Litmus::Auth;
 
+Litmus->init();
+
 use CGI;
-use diagnostics;
+
 
 my $title = "Log in";
 

webtools/litmus/logout.cgi

@@ -33,8 +33,9 @@ $|++;
 use Litmus;
 use Litmus::Auth;
 
-use CGI;
-use diagnostics;
+
+
+Litmus->init();
 
 my $title = "Log out";
 

webtools/litmus/manage_categories.cgi

@@ -42,8 +42,9 @@ use Litmus::FormWidget;
 use CGI;
 use Time::Piece::MySQL;
 
-use diagnostics;
 
+
+Litmus->init();
 Litmus::Auth::requireAdmin("edit_categories.cgi");
 
 my $c = Litmus->cgi();

webtools/litmus/manage_subgroups.cgi

@@ -40,6 +40,7 @@ use CGI;
 use Date::Manip;
 use JSON;
 
+Litmus->init();
 my $c = Litmus->cgi(); 
 
 my $vars;

webtools/litmus/manage_testcases.cgi

@@ -39,6 +39,7 @@ use Litmus::Utils;
 use CGI;
 use Date::Manip;
 
+Litmus->init();
 my $c = Litmus->cgi(); 
 
 my $vars;

webtools/litmus/manage_testgroups.cgi

@@ -40,6 +40,7 @@ use CGI;
 use Date::Manip;
 use JSON;
 
+Litmus->init();
 my $c = Litmus->cgi(); 
 
 my $vars;

webtools/litmus/preview.cgi

@@ -36,6 +36,7 @@ use Litmus::Error;
 use CGI;
 use Date::Manip;
 
+Litmus->init();
 my $c = Litmus->cgi(); 
 print $c->header;
 

webtools/litmus/process_test.cgi

@@ -41,8 +41,9 @@ use Litmus::XML;
 
 use CGI;
 use Date::Manip;
-use diagnostics;
 
+
+Litmus->init();
 my $c = Litmus->cgi(); 
 
 if ($c->param('data')) {

webtools/litmus/run_tests.cgi

@@ -30,7 +30,7 @@
 use strict;
 
 use Time::HiRes qw( gettimeofday tv_interval );
-my $t0 = [gettimeofday];
+our $t0 = [gettimeofday];
 
 use Litmus;
 use Litmus::Error;
@@ -42,9 +42,11 @@ use Litmus::Auth;
 use CGI;
 use Time::Piece::MySQL;
 
-my $title = "Run Tests";
+Litmus->init();
 
-my $c = Litmus->cgi(); 
+our $title = "Run Tests";
+
+our $c = Litmus->cgi(); 
 
 if ($c->param("group")) { # display the test screen
     page_test();

webtools/litmus/runtests.pl

@@ -22,7 +22,7 @@
 #
 
 # Make it harder for us to do dangerous things in Perl.
-use diagnostics;
+
 use strict;
 
 use Test::Harness qw(&runtests $verbose);

webtools/litmus/search_results.cgi

@@ -38,10 +38,11 @@ use Litmus::FormWidget;
 use CGI;
 use Time::Piece::MySQL;
 
+Litmus->init();
 my $c = Litmus->cgi(); 
 print $c->header();
 
-use diagnostics;
+
 
 my $criteria = "Custom<br/>";
 my $results;

webtools/litmus/show_test.cgi

@@ -35,8 +35,9 @@ use CGI;
 use Date::Manip;
 use Time::Piece::MySQL;
 
-use diagnostics;
 
+
+Litmus->init();
 my $c = Litmus->cgi(); 
 
 print $c->header();

webtools/litmus/simpletest.cgi

@@ -39,13 +39,14 @@ use Litmus::Auth;
 use CGI;
 use Time::Piece::MySQL;
 
-my $c = Litmus->cgi(); 
+Litmus->init();
+our $c = Litmus->cgi(); 
 
 # how old of a build do we want to allow? default is 10 days
-my $maxbuildage = 10; 
+our $maxbuildage = 10; 
 # what branch do we accept? default is the trunk or the 1.8 branch
-my $branch = Litmus::DB::Branch->retrieve(1);
-my $branch2 = Litmus::DB::Branch->retrieve(2);
+our $branch = Litmus::DB::Branch->retrieve(1);
+our $branch2 = Litmus::DB::Branch->retrieve(2);
 
 showTest();
 

webtools/litmus/single_result.cgi

@@ -38,6 +38,7 @@ use Litmus::DB::Resultbug;
 use CGI;
 use Date::Manip;
 
+Litmus->init();
 my $c = Litmus->cgi(); 
 print $c->header();
 

webtools/litmus/stats.cgi

@@ -37,6 +37,7 @@ use Litmus::DB::Product;
 use CGI;
 use Time::Piece::MySQL;
 
+Litmus->init();
 my $c = Litmus->cgi(); 
 
 print $c->header();

webtools/litmus/templates/en/default/reporting/test_results.tmpl

@@ -29,7 +29,7 @@
 
 [% IF results %]
 <script type="text/javascript" src="js/Comments.js"></script>
- [% # ZLL 2006-06-19: Timezones are removed from the time being
+ [% # ZLL 2006-06-19: Timezones are removed for now
     # to work around a crash in Time::Piece's strftime on some platforms 
     # (including my own) and to work around formatting nastyness when 
     # it doesn't crash. Add &nbsp;%Z to the end of the strftime string 

webtools/litmus/testlist.cgi

@@ -37,6 +37,7 @@ use Litmus::DB::Product;
 use CGI;
 use Time::Piece::MySQL;
 
+Litmus->init();
 my $c = Litmus->cgi(); 
 
 print $c->header();

webtools/litmus/testrunner_migration/clone_testgroup.pl

@@ -1,137 +0,0 @@
-#!/usr/bin/perl -w
-# -*- mode: cperl; c-basic-offset: 8; indent-tabs-mode: nil; -*-
-
-# ***** BEGIN LICENSE BLOCK *****
-# Version: MPL 1.1
-#
-# The contents of this file are subject to the Mozilla Public License Version
-# 1.1 (the "License"); you may not use this file except in compliance with
-# the License. You may obtain a copy of the License at
-# http://www.mozilla.org/MPL/
-#
-# Software distributed under the License is distributed on an "AS IS" basis,
-# WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
-# for the specific language governing rights and limitations under the
-# License.
-#
-# The Original Code is Litmus.
-#
-# The Initial Developer of the Original Code is
-# the Mozilla Corporation.
-# Portions created by the Initial Developer are Copyright (C) 2006
-# the Initial Developer. All Rights Reserved.
-#
-# Contributor(s):
-#   Chris Cooper <ccooper@deadsquid.com>
-#   Zach Lipton <zach@zachlipton.com>
-#
-# ***** END LICENSE BLOCK *****
-
-use strict;
-$|++;
-
-use lib qw(..);
-
-use Getopt::Long;
-use Litmus::Config;
-use DBI ();
-
-use Data::Dumper;
-use diagnostics;
-
-use vars qw(
-	    $litmus_dbh
-            $testgroup_id
-	    );
-
-END {
-  if ($litmus_dbh) { 
-    $litmus_dbh->disconnect; 
-  }
-}
-
-$litmus_dbh = &connect_litmus() or die;
-
-GetOptions('testgroup_id=i' => \$testgroup_id);
-
-if (!$testgroup_id) {
-  die &usage;
-}
-
-my ($sql,$sth);
-
-$sql="INSERT INTO test_groups (product_id,name,testrunner_plan_id,enabled) SELECT product_id,name,testrunner_plan_id,enabled FROM test_groups WHERE testgroup_id=?";
-
-print $sql,"\n";
-
-my $rv;
-$rv = $litmus_dbh->do($sql,undef,$testgroup_id);
-if ($rv<=0) {
-  die "Testgroup insert failed: $!";
-}
-
-$sql="SELECT MAX(testgroup_id) FROM test_groups";
-$sth = $litmus_dbh->prepare($sql);
-$sth->execute();
-my ($new_testgroup_id) = $sth->fetchrow_array;
-$sth->finish;
-
-if (!$new_testgroup_id) {
-  die "Unable to lookup new testgroup_id!";
-}
-print "New testgroup id: $new_testgroup_id\n";
-
-$sql="SELECT subgroup_id,testgroup_id,name,sort_order,testrunner_group_id,enabled FROM subgroups WHERE testgroup_id=?";
-$sth = $litmus_dbh->prepare($sql);
-$sth->execute($testgroup_id);
-my @subgroups;
-while (my $hashref = $sth->fetchrow_hashref) {
-  push @subgroups, $hashref;
-}
-$sth->finish;
-
-foreach my $subgroup (@subgroups) {
-  $rv = $litmus_dbh->do("INSERT INTO subgroups (testgroup_id,name,sort_order,testrunner_group_id,enabled) VALUES (?,?,?,?,?)",
-                        undef,
-                        $new_testgroup_id,
-                        $subgroup->{'name'},
-                        $subgroup->{'sort_order'},
-                        $subgroup->{'testrunner_group_id'},
-                        $subgroup->{'enabled'},
-                       );                  
-  $sql="SELECT MAX(subgroup_id) FROM subgroups";
-  $sth = $litmus_dbh->prepare($sql);
-  $sth->execute();
-  my ($new_subgroup_id) = $sth->fetchrow_array;
-  $sth->finish;
-  $rv = $litmus_dbh->do("INSERT INTO tests (subgroup_id,summary,details,community_enabled,format_id,regression_bug_id,steps,expected_results,sort_order,author_id,creation_date,last_updated,version,testrunner_case_id,testrunner_case_version,enabled) SELECT $new_subgroup_id,summary,details,community_enabled,format_id,regression_bug_id,steps,expected_results,sort_order,author_id,creation_date,last_updated,version,testrunner_case_id,testrunner_case_version,enabled FROM tests WHERE subgroup_id=?",
-                        undef,
-                        $subgroup->{'subgroup_id'}
-                       );
-}
-
-exit;
-
-#########################################################################
-sub usage() {
-    print "Usage: ./clone_testgroup.pl --testgroup_id=#\n\n";
-}
-
-#########################################################################
-sub connect_litmus() {
-  my $dsn = "dbi:mysql:" . $Litmus::Config::db_name . 
-    ":" . $Litmus::Config::db_host;
-    my $dbh = DBI->connect($dsn,
-                           $Litmus::Config::db_user,
-                           $Litmus::Config::db_pass)
-      || die "Could not connect to mysql database $Litmus::Config::db_name";
-    
-    return $dbh;
-}
-
-
-
-
-
-
-

webtools/litmus/testrunner_migration/import_testplan_from_testrunner.pl

@@ -37,7 +37,7 @@ use Litmus::Config;
 use DBI ();
 
 use Data::Dumper;
-use diagnostics;
+
 
 use vars qw(
             $tr_dbh

webtools/litmus/testrunner_migration/update_litmus_from_testrunner.pl

@@ -37,7 +37,7 @@ use Litmus::Config;
 use DBI ();
 
 use Data::Dumper;
-use diagnostics;
+
 
 use vars qw(
 	    $tr_dbh