DXR is a code search and navigation tool aimed at making sense of large projects. It supports full-text and regex searches as well as structural queries.

Line Code
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
# -*- mode: cperl; c-basic-offset: 8; indent-tabs-mode: nil; -*-

=head1 COPYRIGHT

 # ***** 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>
 #   Max Kanat-Alexander <mkanat@bugzilla.org>
 #   Frederic Wenzel <fwenzel@mozilla.com>
 #
 # ***** END LICENSE BLOCK *****

=cut

# Global object store and function library for Litmus

package Litmus;

use strict;

use Litmus::Template;
use Litmus::Config;
use Litmus::Error;
use Litmus::Auth;
use Litmus::CGI;

use constant MP2 => ( exists $ENV{MOD_PERL_API_VERSION} and 
                        $ENV{MOD_PERL_API_VERSION} >= 2 ); 
use constant MP1 => ( exists $ENV{MOD_PERL} and 
                        ! exists $ENV{MOD_PERL_API_VERSION});                         

our $_request_cache = {};

our $memd;

# 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 shut down by the administrator. Please try again later.";
    	exit;
	}

    # enable memcaching if configured
    if ($Litmus::Config::memcache_settings) {
        use Cache::Memcached::Fast;
        $memd = new Cache::Memcached::Fast($Litmus::Config::memcache_settings);
    }

	# check for pending logins:
	my $c = cgi();
	if ($c->param("login_type")) {
		Litmus::Auth::processLoginForm();
	}
}

# Global Template object
our $template;
sub template() {
	my $class = shift;
	$template ||= Litmus::Template->create();
	return $template;
}
#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;	
    	if (MP2) {
    		$request = Apache2::RequestUtil->request();
    	} elsif (MP1) {
    		$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;