CGI-CIPP
view release on metacpan or search on metacpan
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`;
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;
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";
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 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;
}
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;
}
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;
( run in 0.438 second using v1.01-cache-2.11-cpan-49f99fa48dc )