CGI-CIPP
view release on metacpan or search on metacpan
my $filename = $self->{filename};
# CIPP Parameter
my $perl_code = "";
my $source = $filename;
my $target = \$perl_code;
my $project_hash = undef;
my $db_href = $self->{databases};
my $db;
my $database_hash;
foreach $db (keys %{$db_href}) {
$database_hash->{$db} = "CIPP_DB_DBI";
}
my $default_db = $self->{default_database};
my $mime_type = "text/html";
my $call_path = $self->{uri};
my $skip_header_line = undef;
my $debugging = 0;
my $result_type = "cipp";
my $use_strict = 1;
my $persistent = 0;
my $apache_mod = $self;
my $project = undef;
my $use_inc_cache = 0;
my $lang = $self->{lang};
require "CIPP.pm";
my $CIPP = new CIPP (
$source, $target, $project_hash, $database_hash, $mime_type,
$default_db, $call_path, $skip_header_line, $debugging,
$result_type, $use_strict, $persistent, $apache_mod, $project,
$use_inc_cache, $lang
);
$CIPP->{print_content_type} = 0;
if ( not $CIPP->Get_Init_Status ) {
$self->{error} = "cipp\tcan't initialize CIPP preprocessor";
return;
}
$CIPP->Preprocess;
if ( not $CIPP->Get_Preprocess_Status ) {
my $aref = $CIPP->Get_Messages;
$self->{error} = "cipp-syntax\t".join ("\n", @{$aref});
$self->{cipp_debug_text} = $CIPP->Format_Debugging_Source ();
return;
}
# Wegschreiben
$perl_code =
"# mime-type: $CIPP->{mime_type}\n".
"sub $sub_name {\nmy (\$cipp_apache_request) = \@_;\n".
$perl_code.
"}\n";
$self->write_locked ($sub_filename, \$perl_code);
# Cache-Dependency-File updaten
$self->set_dependency ($CIPP->Get_Used_Macros);
# Perl-Syntax-Check
my %env_backup = %main::ENV; # SuSE 6.0 Workaround
%main::ENV = ();
my $error = `$Config{perlpath} -c -Mstrict $sub_filename 2>&1`;
%main::ENV = %env_backup;
if ( $error !~ m/syntax OK/) {
$error = "perl-syntax\t$error" if $error;
$self->{error} = $error;
return;
}
return 1;
}
sub set_dependency {
my $self = shift;
my ($href) = @_;
my $dep_filename = $self->{dep_filename};
my @list;
push @list, $self->{filename};
if ( defined $href ) {
my $uri;
foreach $uri (keys %{$href}) {
push @list, $self->resolve_uri($uri);
}
}
$self->write_locked ($dep_filename, join ("\t", @list));
}
sub compile {
my $self = shift;
return 1 if $self->sub_cache_ok;
my $sub_name = $self->{sub_name};
my $sub_filename = $self->{sub_filename};
my $sub_sref = $self->read_locked ($sub_filename);
# cut off fist line (with mime type)
$$sub_sref =~ s/^(.*)\n//;
# extract mime type
my $mime_type = $1;
$mime_type =~ s/^#\s*mime-type:\s*//;
# compile the code
eval $$sub_sref;
if ( $@ ) {
$self->{error} = "compilation\t$@";
$CGI::CIPP::compiled{$sub_name} = undef;
return;
}
$CGI::CIPP::compiled{$sub_name} = time;
$CGI::CIPP::mime_type{$sub_name} = $mime_type;
unlink $self->{err_filename};
return 1;
}
sub execute {
my $self = shift;
my $sub_name = $self->{sub_name};
if ( $CGI::CIPP::mime_type{$sub_name} ne 'cipp/dynamic' ) {
$CIPP::REVISION =~ /(\d+\.\d+)/;
my $cipp_revision = $1;
$CGI::CIPP::REVISION =~ /(\d+\.\d+)/;
my $cipp_handler_revision = $1;
print "Content-type: text/html\n\n";
print "<!-- generated by CIPP $CIPP::VERSION/$cipp_revision with ".
"CGI::CIPP $CGI::CIPP::VERSION/$cipp_handler_revision ".
"-->\n";
}
no strict 'refs';
eval { &$sub_name ($self) };
if ( $@ ) {
$self->{error} = "runtime\t$@";
return;
}
return 1;
}
sub error {
my $self = shift;
my $sub_filename = $self->{sub_filename};
my $err_filename = $self->{err_filename};
my $error = $self->{error};
my $uri = $self->{uri};
my ($type) = split ("\t", $error);
if ( $type eq 'cipp-syntax' ) {
$self->write_locked ($err_filename, $error);
} else {
unlink $sub_filename;
unlink $err_filename;
}
$error =~ s/^([^\t]+)\t//;
print "Content-type: text/html\n\n";
print "<HTML><HEAD><TITLE>Error executing $uri</TITLE></HEAD>\n";
print "<BODY BGCOLOR=white>\n";
print "<P>Error executing <B>$uri</B>:\n";
print "<DL><DT><B>Type</B>:</DT><DD><TT>$type</TT></DD>\n";
print "<P><DT><B>Message</B>:</DT><DD><PRE>$error</PRE></DD></DL>\n";
if ( $self->{cipp_debug_text} ) {
print ${$self->{cipp_debug_text}};
}
1;
}
sub debug {
my $self = shift;
my $sub_name = $self->{sub_name};
my $sub_filename = $self->{sub_filename};
my ($k, $v);
my $str = "cache=$sub_filename sub=$sub_name";
while ( ($k, $v) = each %{$self->{status}} ) {
$str .= " $k=$v";
}
return;
while ( ($k, $v) = each %CGI::CIPP::sub_cnt ) {
$self->{debug} && print STDERR ("$k: $v\n");
}
1;
}
# Helper Functions ----------------------------------------------------------------
sub set_sub_filename {
my $self = shift;
my $filename = $self->{uri};
my $cache_dir = $self->{cache_dir};
my $dir = $filename;
$dir =~ s!/[^/]+$!!;
$dir = $cache_dir.$dir;
( mkpath ($dir, 0, 0770) or die "can't create $dir" ) if not -d $dir;
$filename =~ s!^/!!;
$self->{sub_filename} = "$cache_dir/$filename.sub";
return 1;
}
sub set_sub_name {
my $self = shift;
my $uri = $self->{uri};
$uri =~ s!^/!!;
$uri =~ s/\W/_/g;
$self->{sub_name} = "CIPP_Pages::process_$uri";
return 1;
}
sub file_cache_ok {
my $self = shift;
$self->{status}->{file_cache} = 'dirty';
my $cache_file = $self->{sub_filename};
if ( -e $cache_file ) {
my $cache_time = (stat ($cache_file))[9];
my $dep_filename = $self->{dep_filename};
my $data_sref = $self->read_locked ($dep_filename);
my @list = split ("\t", $$data_sref);
my $path;
foreach $path (@list) {
my $file_time = (stat ($path))[9];
return if $file_time > $cache_time;
}
} else {
# check if cache_dir exists and create it if not
mkdir ($self->{cache_dir},0770) if not -d $self->{cache_dir};
return;
}
$self->{status}->{file_cache} = 'ok';
return 1;
}
sub sub_cache_ok {
my $self = shift;
$self->{status}->{sub_cache} = 'dirty';
my $cache_file = $self->{sub_filename};
my $sub_name = $self->{sub_name};
my $cache_time = (stat ($cache_file))[9];
my $sub_time = $CGI::CIPP::compiled{$sub_name};
if ( not defined $sub_time or $cache_time > $sub_time ) {
$CGI::CIPP::sub_cnt{$sub_name} = 0;
return;
}
$self->{status}->{sub_cache} = 'ok';
++$CGI::CIPP::sub_cnt{$sub_name};
return 1;
}
sub has_cached_error {
my $self = shift;
my $err_filename = $self->{err_filename};
if ( -e $err_filename ) {
my $error_sref = $self->read_locked ($err_filename);
$self->{'error'} = $$error_sref;
$self->{status}->{cached_error} = 1;
return 1;
}
return;
}
sub resolve_uri {
my $self = shift;
my ($uri) = @_;
my $filename;
if ( $uri =~ m!^/! ) {
$filename = $self->{document_root}.$uri;
} else {
my $uri_dir = $self->{uri};
$uri_dir =~ s!/[^/]+$!!;
$filename = $self->{document_root}.$uri_dir."/".$uri;
}
$self->{'debug'} && print STDERR "lookup_uri: base=$self->{uri}: '$uri' -> '$filename'\n";
return $filename;
}
sub write_locked {
my $self = shift;
my ($filename, $data) = @_;
my $data_sref;
if ( not ref $data ) {
$data_sref = \$data;
} else {
$data_sref = $data;
}
my $fh = new FileHandle;
open ($fh, "+> $filename") or croak "can't write $filename";
binmode $fh;
flock $fh, LOCK_EX or croak "can't exclusive lock $filename";
seek $fh, 0, 0 or croak "can't seek $filename";
print $fh $$data_sref or croak "can't write data $filename";
truncate $fh, length($$data_sref) or croak "can't truncate $filename";
close $fh;
}
sub read_locked {
my $self = shift;
my ($filename) = @_;
my $fh = new FileHandle;
open ($fh, $filename) or croak "can't read $filename";
binmode $fh;
flock $fh, LOCK_SH or croak "can't share lock $filename";
my $data = join ('', <$fh>);
close $fh;
return \$data;
}
# Apache::Request compatibility routines
sub dir_config {
my $self = shift;
my ($par) = @_;
my $value;
# check if a db_ parameter is requested
if ( $par =~ /^db_([^_]+)_(.*)/ ) {
my ($db, $db_par) = ($1, $2);
$value = $self->{databases}->{$db}->{$db_par};
}
return $value;
}
sub lookup_uri {
my $self = shift;
my ($uri) = @_;
my $filename = $self->resolve_uri ($uri);
return bless \$filename, "CGI::CIPP::Lookup";
}
sub content_type {
my $self = shift;
my ($content_type) = @_;
$self->{content_type} = $content_type;
1;
}
sub header_out {
my $self = shift;
my %par = @_;
$self->{header_out} = \%par;
1;
}
( run in 1.573 second using v1.01-cache-2.11-cpan-364913b4093 )