Bug 40933 for windows
git-svn-id: svn://svn.office.custis.ru/3rdparty/bugzilla.org/trunk@249 6955db30-a419-402b-8a0d-67ecbb4d7f56master
stas
parent
9ffc554a89
commit
d36d5074eb
|
|
@ -58,6 +58,17 @@ use base qw(Bugzilla::Object Exporter);
|
|||
editable_bug_fields
|
||||
);
|
||||
|
||||
#sub import
|
||||
#{
|
||||
# no strict 'refs';
|
||||
# my $pkg = [caller]->[0];
|
||||
# for(@Bugzilla::Bug::EXPORT)
|
||||
# {
|
||||
# *{$pkg."::".$_} = eval "\\&".$_;
|
||||
# die $@ if $@;
|
||||
# }
|
||||
#}
|
||||
|
||||
#####################################################################
|
||||
# Constants
|
||||
#####################################################################
|
||||
|
|
|
|||
|
|
@ -0,0 +1,151 @@
|
|||
package Exporter;
|
||||
|
||||
# Èçâðàùåí÷åñêèé Exporter äëÿ âèíäîâîãî ìîäïåðëà
|
||||
|
||||
require 5.004;
|
||||
|
||||
# Using strict or vars almost doubles our load time. Turn them back
|
||||
# on when debugging.
|
||||
#use strict 'vars'; # we're going to be doing a lot of sym refs
|
||||
#use vars qw($VERSION @EXPORT);
|
||||
|
||||
$VERSION = 0.02;
|
||||
@EXPORT = qw(import); # we'll know pretty fast if it doesn't work :)
|
||||
$ExportLevel = 0;
|
||||
|
||||
sub export_tags {
|
||||
my($exporter, @tags) = @_;
|
||||
my %t = %{$exporter.'::EXPORT_TAGS'};
|
||||
for (@tags)
|
||||
{
|
||||
push @{$exporter.'::EXPORT'}, @{$t{$_}};
|
||||
}
|
||||
}
|
||||
|
||||
sub export_ok_tags {
|
||||
my($exporter, @tags) = @_;
|
||||
my %t = %{$exporter.'::EXPORT_TAGS'};
|
||||
for (@tags)
|
||||
{
|
||||
push @{$exporter.'::EXPORT_OK'}, @{$t{$_}};
|
||||
}
|
||||
}
|
||||
|
||||
sub export_to_level {
|
||||
my($exporter, $level, $package, @imports) = @_;
|
||||
my($caller, $file, $line) = caller($level);
|
||||
|
||||
unless( @imports ) { # Default import.
|
||||
@imports = @{$exporter.'::EXPORT'};
|
||||
}
|
||||
else {
|
||||
# Because @EXPORT_OK = () would indicate that nothing is
|
||||
# to be exported, we cannot simply check the length of @EXPORT_OK.
|
||||
# We must to oddness to see if the variable exists at all as
|
||||
# well as avoid autovivification.
|
||||
# XXX idea stolen from base.pm, this might be all unnecessary
|
||||
my $eokglob;
|
||||
if( $eokglob = ${$exporter.'::'}{EXPORT_OK} and *$eokglob{ARRAY} ) {
|
||||
if( @{$exporter.'::EXPORT_OK'} ) {
|
||||
# This can also be cached.
|
||||
my %ok = map { s/^&//; $_ => 1 } @{$exporter.'::EXPORT_OK'},
|
||||
@{$exporter.'::EXPORT'};
|
||||
|
||||
my($denied) = grep {s/^&//; !/(^\d*(\.\d+)*$|^:|^!)/ && !$ok{$_}} @imports;
|
||||
_not_exported($denied, $exporter, $file, $line) if $denied;
|
||||
}
|
||||
else { # We don't export anything.
|
||||
_not_exported($imports[0], $exporter, $file, $line);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
export($caller, $exporter, @imports);
|
||||
}
|
||||
|
||||
sub import {
|
||||
my($exporter, @imports) = @_;
|
||||
my($caller, $file, $line) = caller($ExportLevel);
|
||||
|
||||
unless( @imports ) { # Default import.
|
||||
@imports = @{$exporter.'::EXPORT'};
|
||||
}
|
||||
else {
|
||||
# Because @EXPORT_OK = () would indicate that nothing is
|
||||
# to be exported, we cannot simply check the length of @EXPORT_OK.
|
||||
# We must to oddness to see if the variable exists at all as
|
||||
# well as avoid autovivification.
|
||||
# XXX idea stolen from base.pm, this might be all unnecessary
|
||||
my $eokglob;
|
||||
if( $eokglob = ${$exporter.'::'}{EXPORT_OK} and *$eokglob{ARRAY} ) {
|
||||
if( @{$exporter.'::EXPORT_OK'} ) {
|
||||
# This can also be cached.
|
||||
my %ok = map { s/^&//; $_ => 1 } @{$exporter.'::EXPORT_OK'},
|
||||
@{$exporter.'::EXPORT'};
|
||||
|
||||
my($denied) = grep {s/^&//; !/(^\d*(\.\d+)*$|^:|^!)/ && !$ok{$_}} @imports;
|
||||
_not_exported($denied, $exporter, $file, $line) if $denied;
|
||||
}
|
||||
else { # We don't export anything.
|
||||
_not_exported($imports[0], $exporter, $file, $line);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
export($caller, $exporter, @imports);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub export {
|
||||
my($caller, $exporter, @imp) = @_;
|
||||
|
||||
my %t = %{$exporter.'::EXPORT_TAGS'};
|
||||
my @imports;
|
||||
for(@imp)
|
||||
{
|
||||
if (substr($_,0,1) eq ':')
|
||||
{
|
||||
push @imports, @{$t{substr($_,1)}};
|
||||
}
|
||||
elsif (substr($_,0,1) eq '!')
|
||||
{
|
||||
my $n = substr($_,1);
|
||||
@imports = grep { $_ ne $n } @imports;
|
||||
}
|
||||
else
|
||||
{
|
||||
push @imports, $_;
|
||||
}
|
||||
}
|
||||
|
||||
# Stole this from Exporter::Heavy. I'm sure it can be written better
|
||||
# but I'm lazy at the moment.
|
||||
foreach my $sym (@imports) {
|
||||
# shortcut for the common case of no type character
|
||||
(*{$caller.'::'.$sym} = \&{$exporter.'::'.$sym}, next)
|
||||
unless $sym =~ s/^(\W)//;
|
||||
|
||||
my $type = $1;
|
||||
my $caller_sym = $caller.'::'.$sym;
|
||||
my $export_sym = $exporter.'::'.$sym;
|
||||
*{$caller_sym} =
|
||||
$type eq '&' ? \&{$export_sym} :
|
||||
$type eq '$' ? \${$export_sym} :
|
||||
$type eq '@' ? \@{$export_sym} :
|
||||
$type eq '%' ? \%{$export_sym} :
|
||||
$type eq '*' ? *{$export_sym} :
|
||||
do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#"#
|
||||
sub _not_exported {
|
||||
my($thing, $exporter, $file, $line) = @_;
|
||||
die sprintf qq|"%s" is not exported by the %s module at %s line %d\n|,
|
||||
$thing, $exporter, $file, $line;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
|
@ -0,0 +1,119 @@
|
|||
#!/usr/bin/perl -wT
|
||||
# -*- Mode: perl; indent-tabs-mode: nil -*-
|
||||
#
|
||||
# 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 the Bugzilla Bug Tracking System.
|
||||
#
|
||||
# Contributor(s): Max Kanat-Alexander <mkanat@bugzilla.org>
|
||||
|
||||
package Bugzilla::ModPerl;
|
||||
|
||||
use strict;
|
||||
|
||||
# If you have an Apache2::Status handler in your Apache configuration,
|
||||
# you need to load Apache2::Status *here*, so that Apache::DBI can
|
||||
# report information to Apache2::Status.
|
||||
#use Apache2::Status ();
|
||||
|
||||
# We don't want to import anything into the global scope during
|
||||
# startup, so we always specify () after using any module in this
|
||||
# file.
|
||||
|
||||
use Apache2::ServerUtil;
|
||||
use ModPerl::RegistryLoader ();
|
||||
use CGI ();
|
||||
CGI->compile(qw(:cgi -no_xhtml -oldstyle_urls :private_tempfiles
|
||||
:unique_headers SERVER_PUSH :push));
|
||||
use Template::Config ();
|
||||
Template::Config->preload();
|
||||
|
||||
use Bugzilla ();
|
||||
use Bugzilla::Constants ();
|
||||
use Bugzilla::CGI ();
|
||||
use Bugzilla::Mailer ();
|
||||
use Bugzilla::Template ();
|
||||
use Bugzilla::Util ();
|
||||
|
||||
my $cgi_path = Bugzilla::Constants::bz_locations()->{'cgi_path'};
|
||||
|
||||
# Set up the configuration for the web server
|
||||
my $server = Apache2::ServerUtil->server;
|
||||
my $conf = <<EOT;
|
||||
# Make sure each httpd child receives a different random seed (bug 476622)
|
||||
PerlChildInitHandler "sub { srand(); }"
|
||||
<Directory "$cgi_path">
|
||||
AddHandler perl-script .cgi
|
||||
# No need to PerlModule these because they're already defined in mod_perl.pl
|
||||
PerlResponseHandler Bugzilla::ModPerl::ResponseHandler
|
||||
PerlCleanupHandler Bugzilla::ModPerl::CleanupHandler
|
||||
PerlOptions +ParseHeaders
|
||||
Options +ExecCGI
|
||||
AllowOverride Limit
|
||||
DirectoryIndex index.cgi index.html
|
||||
</Directory>
|
||||
EOT
|
||||
|
||||
if ($^O =~ /MSWin32/i)
|
||||
{
|
||||
$conf = "<Perl>\nuse lib qw(lib/win32);\n</Perl>\n$conf";
|
||||
}
|
||||
|
||||
$server->add_config([split("\n", $conf)]);
|
||||
|
||||
# Have ModPerl::RegistryLoader pre-compile all CGI scripts.
|
||||
my $rl = new ModPerl::RegistryLoader();
|
||||
# If we try to do this in "new" it fails because it looks for a
|
||||
# Bugzilla/ModPerl/ResponseHandler.pm
|
||||
$rl->{package} = 'Bugzilla::ModPerl::ResponseHandler';
|
||||
# Note that $cgi_path will be wrong if somebody puts the libraries
|
||||
# in a different place than the CGIs.
|
||||
foreach my $file (glob "$cgi_path/*.cgi") {
|
||||
Bugzilla::Util::trick_taint($file);
|
||||
$rl->handler($file, $file);
|
||||
}
|
||||
|
||||
|
||||
package Bugzilla::ModPerl::ResponseHandler;
|
||||
use strict;
|
||||
use base qw(ModPerl::Registry);
|
||||
use Bugzilla;
|
||||
|
||||
sub handler : method {
|
||||
my $class = shift;
|
||||
|
||||
# $0 is broken under mod_perl before 2.0.2, so we have to set it
|
||||
# here explicitly or init_page's shutdownhtml code won't work right.
|
||||
$0 = $ENV{'SCRIPT_FILENAME'};
|
||||
|
||||
Bugzilla::init_page();
|
||||
return $class->SUPER::handler(@_);
|
||||
}
|
||||
|
||||
|
||||
package Bugzilla::ModPerl::CleanupHandler;
|
||||
use strict;
|
||||
use Apache2::Const -compile => qw(OK);
|
||||
|
||||
sub handler {
|
||||
my $r = shift;
|
||||
|
||||
Bugzilla::_cleanup();
|
||||
# Sometimes mod_perl doesn't properly call DESTROY on all
|
||||
# the objects in pnotes()
|
||||
foreach my $key (keys %{$r->pnotes}) {
|
||||
delete $r->pnotes->{$key};
|
||||
}
|
||||
|
||||
return Apache2::Const::OK;
|
||||
}
|
||||
|
||||
1;
|
||||
Loading…
Reference in New Issue