view release on metacpan or  search on metacpan

CIPP.pm  view on Meta::CPAN

	# CIPP Parameter
	my $perl_code = "";
	
	my $source = $filename;
	my $target = \$perl_code;
	my $project_hash = undef;
	
	my $databases = $r->dir_config ("databases");
	my @databases = split (/\s*,\s*/, $databases);
	my $db;
	my $database_hash;
	foreach $db (@databases) {
		$database_hash->{$db} = "CIPP_DB_DBI";
	}
	my $default_db = $r->dir_config ("default_db");

	my $mime_type = "text/html";
	my $call_path = $r->uri;
	my $skip_header_line = undef;
	my $debugging = 0;
	my $result_type = "cipp";
	my $use_strict = 1;
	my $persistent = 0;
	my $apache_mod = $r;
	my $project = undef;
	my $use_inc_cache = 0;
	my $lang = $r->dir_config ("lang");

	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
	my $output = new FileHandle;
	open ($output, "> $sub_filename") or die "can't write $sub_filename";
	print $output "# mime-type: $CIPP->{mime_type}\n";
	print $output "sub $sub_name {\nmy (\$cipp_apache_request) = \@_;\n";
	print $output $perl_code;
	print $output "}\n";
	close $output;

	# 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 $r = $self->{r};
	
	my @list;
	push @list, $self->{filename};

	if ( defined $href ) {
		my $uri;
		foreach $uri (keys %{$href}) {
			my $subr = $r->lookup_uri($uri);
			push @list, $subr->filename;
		}
	}

	open (DEP, "> $dep_filename") or die "can't write $dep_filename";
	print DEP join ("\t", @list);
	close DEP;
}

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 $input = new FileHandle;
	
	open ($input, $sub_filename) or die "can't read $sub_filename";
	my $mime_type = <$input>;
	$mime_type =~ s/^#\s*mime-type:\s*//;
	chop $mime_type;
	my $sub = join ('', <$input>);
	close $input;