view release on metacpan or  search on metacpan

CIPP.pm  view on Meta::CPAN

	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};