File Coverage

blib/lib/CIPP/Compile/NewSpirit.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

# $Id: NewSpirit.pm,v 1.23 2006/05/16 14:58:29 joern Exp $

package CIPP::Compile::NewSpirit;

@ISA = qw ( CIPP::Compile::Generator );

use strict;
use Carp;
use FileHandle;
use File::Basename;
use CIPP::Compile::Generator;

sub new {
	my $type = shift;
	my %par = @_;
	my  ($shebang, $project_root, $project_prod, $mime_type) =
	@par{'shebang','project_root','project_prod','mime_type'};

	confess "Please specify the following parameters:\n".
	      "project_root\n".
	      "Got: ".join(', ', keys(%par))."\n"
	      	unless $project_root;

	my $self = bless $type->SUPER::new(@_), $type;

	my $back_prod_path = $self->get_program_name;
	$back_prod_path =~ s!\.!/!g;
	$back_prod_path =~ s![^/]+!..!g;

	$self->set_gen_ns_shebang ($shebang);
	$self->set_gen_ns_project_root ($project_root);
	$self->set_gen_ns_project_prod ($project_prod);
	$self->set_gen_ns_back_prod_path ($back_prod_path);

	$self->get_state->{autoprint} = 1 if $mime_type ne 'cipp/dynamic';

	my $program_name = $self->get_program_name;
	$program_name =~ s/^[^.]+/$self->get_project/e;
	$self->{program_name} = $program_name;

	( $self->{in_filename}, $self->{out_filename},
	  $self->{prod_filename}, $self->{dep_filename},
	  $self->{iface_filename}, $self->{err_filename},
	  $self->{http_filename} )
	  	= $self->get_object_filenames;

	$self->set_err_copy_filename ($self->get_out_filename.".err");

	# cipp-html objects always depend on the base configuration
	if ( $self->get_object_type eq 'cipp-html' ) {
		$self->add_used_object (
			name => "x.configuration",
			ext  => "cipp-base-config",
			type => "cipp-base-conf",
		);
		$self->set_dont_cache (1);
	}

	return $self;
}

sub get_gen_ns_shebang		{ shift->{gen_ns_shebang}		}
sub get_gen_ns_back_prod_path	{ shift->{gen_ns_back_prod_path}	}
sub get_gen_ns_project_root	{ shift->{gen_ns_project_root}		}
sub get_gen_ns_project_prod	{ shift->{gen_ns_project_prod}		}

sub set_gen_ns_shebang		{ shift->{gen_ns_shebang}	= $_[1]	}
sub set_gen_ns_back_prod_path	{ shift->{gen_ns_back_prod_path}= $_[1]	}
sub set_gen_ns_project_root	{ shift->{gen_ns_project_root}	= $_[1]	}
sub set_gen_ns_project_prod	{ shift->{gen_ns_project_prod}	= $_[1]	}

#---------------------------------------------------------------------
# This interface must be implemented by the Generator/* modules
#---------------------------------------------------------------------

sub create_new_parser {
	my $self = shift; $self->trace_in;
	my %par = @_;
	my  ($object_type, $program_name, $in_filename, $in_fh) =
	@par{'object_type','program_name','in_filename','in_fh'};

	my $parser = (ref $self)->new (
		object_type   => $object_type,
		program_name  => $program_name,
		in_filename   => $in_filename,
		in_fh 	      => $in_fh,
		project       => $self->get_project,
		start_context => $self->get_start_context,	# ??? not actual context?
		shebang       => $self->get_gen_ns_shebang,
		project_root  => $self->get_gen_ns_project_root,
		lib_path      => $self->get_lib_path,
	);

	$parser->set_inc_trace (
		$self->get_inc_trace.$self->get_normalized_object_name (
			name => $program_name
		).":"
	);

	return $parser;
}

sub generate_start_program {
	my $self = shift; $self->trace_in;

	$self->write($self->get_gen_ns_shebang, "\n\n");
	$self->write ("use strict;\n\n");
	$self->write ("package main;\n\n");
	$self->write ('my ($_cipp_project, $_cipp_line_nr);'."\n\n");

	1;
}

sub generate_project_handler {
	my $self = shift; $self->trace_in;

	$self->writef (<<'__EOC'
use CIPP::Runtime::NewSpirit;

BEGIN {#
  #-- Do initialization in a BEGIN block, to get a proper
  #-- @INC, so "use Some::Module::Coded::In::CIPP" will work.
  CIPP::Runtime::NewSpirit::Project->init (
      project        => "%s",
      back_prod_path => "%s",
  );
}

#-- Do initialization (again). We couldn't get the $_cipp_project
#-- Variable out of the BEGIN{} block above, so we need to
#-- get it here. Also the BEGIN block above is executed only once
#-- in persistent environments (mod_perl, SpeedyCGI). Double
#-- initialization is prevented by the init() method itself, the
#-- overhead here is minimal.
$_cipp_project = CIPP::Runtime::NewSpirit::Project->init (
    project        => "%s",
    back_prod_path => "%s",
);
__EOC
		, $self->get_project,
		  $self->get_gen_ns_back_prod_path,
		  $self->get_project,
		  $self->get_gen_ns_back_prod_path,
	);
}

sub generate_open_request {
	my $self = shift; $self->trace_in;

	$self->write (
		'$_cipp_project->new_request ('."\n",
		'    program_name => "'.$self->get_program_name.'",'."\n",
		'    mime_type => "'.$self->get_mime_type,'",'."\n",
		');'."\n\n",
	);

	if ( not $self->get_no_http_header ) {
		my $http_header_file = $self->custom_http_header_file;
		if ( $http_header_file ) {
			$self->writef (
				'$CIPP::request->print_http_header ('."\n".
				'  custom_http_header_file => "%s",'."\n".
				');'."\n",
				$http_header_file
			);
		} else {
			$self->write (
				'$CIPP::request->print_http_header;'."\n",
			);
		}
	}

	1;
}

sub get_normalized_object_name {
	my $self = shift; $self->trace_in;
	my %par = @_;
	my ($name) = @par{'name'};

	$name =~ s/^[^.]+\.//;
	$name =~ tr!.!/!;

	return $name;
}

sub get_object_filename {
	my $self = shift; $self->trace_in;
	my %par = @_;
	my  ($name, $name_is_normalized) =
	@par{'name','name_is_normalized'};

	my $file;
	if ( $name_is_normalized ) {
		$file = $name;
	} else {
		$file = $self->get_normalized_object_name ( name => $name );
	}

	$file = $self->get_gen_ns_project_root."/src/".$file;

	my $dir = dirname $file;
	my $filename = basename $file;

	my $dh = FileHandle->new;
	opendir $dh, $dir or return;
	my @filenames = grep (!/\.m$/, (grep /^$filename\.[^\.]+$/, readdir $dh));
	closedir $dh;

	return if scalar @filenames != 1;
	return $dir."/".$filenames[0];
}

sub determine_object_type {
	my $self = shift; $self->trace_in;
	my %par = @_;
	my ($name, $filename) = @par{'name','filename'};

	confess "name *and* filename given" if $name and $filename;

	$filename ||= $self->get_object_filename ( name => $name );
	return if not defined $filename;

	$filename =~ /\.([^\.]+)$/;

	my $ext = $1;
	my $type = $ext;

	if ( $ext =~ /^(gif|jpg|jpeg|jpe|png)$/i ) {
		$type = 'cipp-img';
	} elsif ( $ext eq 'ns-unknown' ) {
		$type = 'generic';
	} elsif ( $ext =~ /^(jar|cab|class|properties)$/i ) {
		$type = 'jar';
	} elsif ( $ext =~ /^cipp-/ and
		  $ext !~ /^cipp-(config|db|module|inc|sql)$/ ) {
		$type = 'cipp-html';
	} elsif ( $ext =~ /^(js|css|txt|html)$/ ) {
		$type = 'text'
	}

	return $type;
}

sub get_object_url {
	my $self = shift; $self->trace_in;
	my %par = @_;
	my  ($name, $add_message_if_has_no) =
	@par{'name','add_message_if_has_no'};

	my $object_url;
	eval {
		my $filename    = $self->get_object_filename ( name => $name ) or die;
		my $object_type = $self->determine_object_type ( filename => $filename ) or die;

		my $src_dir = $self->get_gen_ns_project_root."/src";
		$filename =~ s!^$src_dir/?!!;
		$filename =~ s!\.([^\.]+)$!!;
		my $ext = $1;

		if ( $object_type eq 'cipp' ) {
			$object_url = '}.$CIPP::request->get_cgi_url.qq{/'.$filename.'.cgi';

		} elsif ( $object_type eq 'cipp-html' or $object_type eq 'text' or
		 	  $object_type eq 'jar' ) {
			$ext =~ m!cipp-(.*)$!;
			$object_url = '}.$CIPP::request->get_doc_url.qq{/'.$filename.".$1";

		} elsif ( $object_type eq 'cipp-img' or $object_type eq 'blob' ) {
			$object_url = '}.$CIPP::request->get_doc_url.qq{/'.$filename.".".$ext;

		} elsif ( $object_type eq 'generic' ) {
			my $meta_file = $self->get_object_filename ( name => $name ).".m";
			die if not -r $meta_file;
			my $meta_data = do $meta_file;
			die if not $meta_data->{install_target_dir};
			$filename =~ s![^/]+$!!;
			my $orig_filename = $meta_data->{_original_filename};
			if ( $meta_data->{install_target_dir} eq 'htdocs' ) {
				$object_url = '}.$CIPP::request->get_doc_url.qq{'.
					      $filename.'/'.$orig_filename;
			} else {
				$object_url = '}.$CIPP::request->get_cgi_url.qq{'.
					      $filename.'/'.$orig_filename;
			}
			$object_url =~ s!/+!/!g;
		} else {
			confess "unknown object type '$object_type'";
		}
	};

	$self->add_tag_message (
		message => "The object '$name' has no URL."
	) if not $object_url and $add_message_if_has_no;

	return $object_url;
}

sub get_object_filenames {
	my $self = shift; $self->trace_in;
	my %par = @_;
	my  ($norm_name, $object_type) =
	@par{'norm_name','object_type'};

	$norm_name   ||= $self->get_normalized_object_name
				( name => $self->get_program_name );
	$object_type ||= $self->get_object_type;

	my $base_dir = $self->get_gen_ns_project_root;
	my $project  = $self->get_project;
	my $prod_dir = $self->get_gen_ns_project_prod;

	$prod_dir ||= "$base_dir/prod";

	my ($in_filename, $out_filename, $prod_filename,
	    $dep_filename, $iface_filename, $err_filename,
	    $http_filename);

	if ( $object_type eq 'cipp-inc' ) {
		$in_filename	    = "$base_dir/src/$norm_name.cipp-inc";
		$out_filename       = "$prod_dir/inc/$norm_name.code";
		$prod_filename      = "$prod_dir/inc/$norm_name.code";
		$dep_filename	    = "$base_dir/meta/##cipp_dep/$norm_name.dep";
		$iface_filename     = "$base_dir/meta/##cipp_dep/$norm_name.iface";
		$err_filename       = "$base_dir/meta/##cipp_dep/$norm_name.err";
		$http_filename      = "$prod_dir/inc/$norm_name.http";

	} elsif ( $object_type eq 'cipp' ) {
		$in_filename	    = "$base_dir/src/$norm_name.cipp";
		$out_filename       = "$prod_dir/cgi-bin/$project/$norm_name.cgi";
		$prod_filename      = "$prod_dir/cgi-bin/$project/$norm_name.cgi";
		$dep_filename	    = "$base_dir/meta/##cipp_dep/$norm_name.dep";
		$iface_filename     = "";
		$err_filename       = "$base_dir/meta/##cipp_dep/$norm_name.err";
		$http_filename      = "$prod_dir/inc/$norm_name.http";

	} elsif ( $object_type eq 'cipp-html' ) {
		my $src_filename = $self->get_object_filename (
			name => $norm_name,
			name_is_normalized => 1
		);

		confess "can't resolve source filename for object '$norm_name'"
			if not $src_filename;

		$src_filename =~ /cipp-(.*)$/;
		my $ext = $1;

		$in_filename	    = "$base_dir/src/$norm_name.cipp-$ext";
		$out_filename       = "/tmp/cipp_html_$$";
		$prod_filename      = "$prod_dir/htdocs/$project/$norm_name.$ext";
		$dep_filename	    = "$base_dir/meta/##cipp_dep/$norm_name.dep";
		$iface_filename     = "";
		$err_filename       = "$base_dir/meta/##cipp_dep/$norm_name.err";
		$http_filename      = "";

	} elsif ( $object_type eq 'cipp-module' ) {
		my $module_name = $self->get_module_name;
		$module_name =~ s!::!/!g;

		$in_filename	    = "$base_dir/src/$norm_name.cipp-module";
		$out_filename       = "/tmp/cipp_module_$$";

		if ( not $module_name ) {
			$prod_filename = "/tmp/cipp_module_$$";
		} else {
			$prod_filename = "$prod_dir/lib/$module_name.pm";
		}

		$dep_filename	    = "$base_dir/meta/##cipp_dep/$norm_name.dep";
		$iface_filename     = "";
		$err_filename       = "$base_dir/meta/##cipp_dep/$norm_name.err";
		$http_filename      = "";

	} else {
		confess "unknown object type '$object_type'";
	}

	return ($in_filename,    $out_filename,
		$prod_filename,  $dep_filename,
		$iface_filename, $err_filename,
		$http_filename);
}

sub get_relative_inc_path {
	my $self = shift;
	my %par = @_;
	my ($filename) = @par{'filename'};

	my $base_dir = $self->get_gen_ns_project_root;

	$filename =~ s!^$base_dir/prod/inc/!!;

	return $filename;
}

sub determine_text_domain {
        my $self = shift;

        my $last_dir = $self->get_in_filename;

        while ( 1 ) {
            my $dir = dirname($last_dir);
            last if $last_dir eq $dir;
            $last_dir = $dir;
            my $file = "$dir/po/domain.text-domain";
            if ( -f $file ) {
                open (my $fh, $file) or die "can't read $file";
                my $domain = <$fh>;
                chomp $domain;
                close $fh;
                return $domain;
            }
        }

        return;
}

1;