File Coverage

lib/CGI/PathRequest.pm

Criterion	Covered	Total	%
statement	240	301	79.7
branch	84	128	65.6
condition	15	27	55.5
subroutine	37	48	77.0
pod	22	32	68.7
total	398	536	74.2

package CGI::PathRequest;
use strict;
use warnings;
use File::MMagic;
use base 'File::PathInfo::Ext';
use Carp;
use CGI;
use HTML::Entities;
use vars qw/$VERSION $DEBUG/;
$VERSION = sprintf "%d.%02d", q$Revision: 1.19 $ =~ /(\d+)/g;
$DEBUG = 0;
sub DEBUG : lvalue { $DEBUG }

sub new {
	my ($class, $self) = (shift, shift);
	if (defined $self and ref $self ne 'HASH'){
		$self = __PACKAGE__->SUPER::new($self);
	}

	$self								||= {};
	$self->{param_name}		   ||= 'rel_path';
	$self->{default}			   ||= undef; # what is the default
	$self->{tainted_request}   and ( $self->{rel_path} = $self->{tainted_request} );
	$self->{rel_path}			   ||= undef;
	$self->{excerpt_size}		||= 255; # chars if excerpt is called for
	$self->{status}				= [];
	$self->{request_made}		= 0; # was a request received

	$self->{tainted_request}
      and carp('warning: argument tainted_path to CGI::PathRequest is deprecated.');
	$self->{default}
      and carp("use of 'default' to CGI::PathRequest is deprecated");

	bless $self, $class;


   if ($self->_arg){
      ### settiong
	   $self->set( $self->_arg ) or return; #or $self->{data}->{exists} = 0;
   }

   ### ok
	return $self;
}

sub exists {
	my $self = shift;
	if (defined $self->{data}->{exists}){
		return $self->{data}->{exists};
	}
	( -e $self->abs_path ) ? ( $self->{data}->{exists} = 1) : ($self->{data}->{exists} = 0);
	return $self->{data}->{exists};
}




# run once!?
sub _arg {
	my $self = shift;

	unless ( defined $self->{_arg} ){
		### getting _arg
		my $argument = undef;

		if (defined $self->{rel_path}){
			#### from constructor
			$self->{request_method} = 'constructor argument';

			$argument = $self->{rel_path};
		}


		elsif ( my $fromcgi = $self->_get_rel_path_from_cgi ){
			#### from cgi
			$self->{request_method} = 'from cgi';
			$argument= $fromcgi;
		}

		else {
			#### none
			$self->{request_method} = 'none';
		}

	#	if( $argument ){
		#	$argument=~s/^\///; # hack
	#	}

		#$argument ||= $self->DOCUMENT_ROOT;
		#### $argument

      defined $argument or return;
		$self->DOCUMENT_ROOT or die("DOCUMENT_ROOT not defined?");
		if ( -e $self->DOCUMENT_ROOT .'/'.$argument ){
			$argument = $self->DOCUMENT_ROOT .'/'.$argument;
		}


		$self->{_arg} = $argument;
	}

	return $self->{_arg};
}

# NETWORK METHODS ...... cgi and host etc. www. etc etc

sub _network {
	my $self = shift;

	unless (defined $self->{_data}->{_network}){

		my $data = { server_name => undef };

		if (defined $self->{SERVER_NAME}){
			$data->{server_name} = $self->{SERVER_NAME};
		}

		elsif (defined $ENV{SERVER_NAME}){
			$data->{server_name} = $ENV{SERVER_NAME};
		}

		elsif ($self->get_cgi->server_name)  {
			$data->{server_name} = $self->get_cgi->server_name;
		}

		if ( $data->{server_name} ) { # we can get server name

			if ($self->get_cgi->https){
				$data->{www} = 'https://'.$data->{server_name};
			}
			else {
				$data->{www} = 'http://'.$data->{server_name};
			}

			# how we see from the net
			$data->{url} = $data->{www} .'/'.$self->rel_path;

		}

		$self->{_data}->{_network} = $data;
	}

	return $self->{_data}->{_network};
}

sub server_name {
	my $self = shift;
	#return $self->get_cgi->server_name;
	return $self->_network->{server_name};
}

sub url {
	my $self = shift;
	return $self->_network->{url};
}

sub www {
	my $self = shift;
	return $self->_network->{www};
}

sub get_cgi {
	my $self = shift;
	$self->{ cgi }	||= new CGI;
	return $self->{cgi};
}





















# test existancem, type, etc
# will attempt to default IF DOES NOT EXIST
sub _extended {
	my $self = shift;

	croak($self->errstr) if $self->errstr;

	if (defined $self->{_data}->{_extended}){
		return $self->{_data}->{_extended};
	}


	my $data = {};


	# TODO: presently not doing anything for other file types, pipes, etc

	if ($self->is_dir){
		$data->{filetype}='d';
	}
	elsif ($self->is_file){
		$data->{filetype}='f';
	}
	else {
		warn "filetype for $$data{abs_path} is not d or f, unsupported.";
	}

	$data->{is_root} = ( $self->is_DOCUMENT_ROOT ? 1 : 0 );

	$data->{filename_pretty}= $self->filename_only or die('filename_only returns nothing?'.$self->abs_path);
	$data->{filename_pretty}=~s/_/ /sg;
	$data->{filename_pretty} = join '', map {ucfirst lc} split (/(?=\s)/, $data->{filename_pretty}); # http://perlmonks.org/?node_id=471292

	$data->{alt} = $data->{filename_pretty};
	$data->{is_html} = $self->is_html;
	$self->{_data}->{_extended} = $data;

	return $self->{_data}->{_extended};
}

sub is_html {
	my $self = shift;
	$self->is_text or return 0;
	$self->ext=~/s?html?$/i or return 0;
	return 1;
}

sub is_root {
	my $self = shift;
	return $self->_extended->{is_root};
}

sub filename_pretty {
	my $self = shift;
	return $self->_extended->{filename_prety};
}
sub alt  {
  my $self = shift;
  return $self->_extended->{alt};
}

sub filetype  {
  my $self = shift;

  return $self->_extended->{filetype};
}


# mime type etc, maybe should be in File::PathInfo.. ?? hmmmm
sub _more {
	my $self = shift;

	croak($self->errstr) if $self->errstr;

	unless (defined $self->{_data}->{_extended_more} ){

		my $mime_type = undef;;
		unless ($self->is_dir){
			my $m = new File::MMagic;
			$mime_type = $m->checktype_filename( $self->abs_path );
		}


		my $data = {
		 	is_image			=> ( $self->is_file ? ( $mime_type=~m/image/ or 0 ) : 0 ),
			mime_type		=> $mime_type,
		};

		$self->{_data}->{_extended_more} = $data;
	}

	return $self->{_data}->{_extended_more};
}

sub is_image  {
 my $self = shift;
 return $self->_more->{is_image};
}

sub mime_type  {
 my $self = shift;
 return $self->_more->{mime_type};
}



# content and excerpt
sub _guts {
	my $self = shift;

	croak($self->errstr) if $self->errstr;

	$self->is_text or return {}; # TODO: is this right?


	unless( defined $self->{_data}->{_guts} ){
		my $guts = {};

		my $slurp;
		{
			local (*INPUT, $/);
			open (INPUT, $self->abs_path);
			$slurp = ;
			close INPUT;
		}
		$guts->{content} = $slurp;
		$guts->{content} ||= undef;


		if( $guts->{content} ){

			$self->{excerpt_size} ||= 255;
			my $limit = $self->{excerpt_size};

			$guts->{excerpt} = $guts->{content};
			$guts->{excerpt}=~s/\<[^<>]+\>/ /sg; # take out html

			$guts->{excerpt}=~s/^(.{1,$limit}).+/$1\.\.\./s;

			$guts->{excerpt_encoded} = encode_entities($guts->{excerpt});

		}
		$self->{_data}->{_guts} = $guts;

	}

	return $self->{_data}->{_guts};
}

sub get_content {
	my $self = shift;
	return $self->_guts->{content};
}

sub get_excerpt {
	my $self = shift;
	return $self->_guts->{excerpt};
}

# made decision not to do this 'by default' with the whole content to be more frugal
sub get_content_encoded {
	my $self = shift;
	my $out = encode_entities( $self->_guts->{content} );
	return $out;
}

sub get_excerpt_encoded {
	my $self = shift;
	return $self->_guts->{excerpt_encoded};
}













# LS METHODS


# must be loaded
sub _ls {
	my $self = shift;
	$self->is_dir or warn $self->abs_path ."is not a dir" and return {};


	unless ( defined $self->{_data}->{_ls} ){
		my $data={};

		opendir(DIR, $self->abs_path)
			or croak("$! - cant open dir ".$self->abs_path.", check permissions?");
		my @ls = sort grep { !/^\.+$/ } readdir DIR;
		closedir DIR;


		my @lsd = grep { -d $self->abs_path."/$_" } @ls;
		my @lsf = grep { -f $self->abs_path."/$_" } @ls;

		$data->{ls}  = \@ls;
		$data->{lsd} = \@lsd;
		$data->{lsf} = \@lsf;

		$data->{ls_count}  = scalar @ls;
		$data->{lsd_count} = scalar @lsd;
		$data->{lsf_count} = scalar @lsf;

		$self->{_data}->{_ls} = $data;
	}

	return $self->{_data}->{_ls};
}

sub ls {
	my $self = shift;
	return $self->_ls->{ls};
}

sub lsd {
	my $self = shift;
	return $self->_ls->{lsd};
}

sub lsf {
	my $self = shift;
	return $self->_ls->{lsf};
}

sub ls_count {
	my $self = shift;
	return $self->_ls->{ls_count};
}

sub lsd_count {
	my $self = shift;
	return $self->_ls->{lsd_count};
}

sub lsf_count {
	my $self = shift;
	return $self->_ls->{lsf_count};
}

sub is_empty_dir {
	my $self = shift;
	$self->is_dir or return;
	$self->ls_count or return 1;
	return 0;
}




# HTML::Template METHODS

sub nav_prepped {
	my $self = shift;

	unless ( defined $self->{_data}->{nav_loop} ){

		my $onetime=0;

		my @nav_loop=();

		my $r = $self; # start by self



		until ( $r->is_DOCUMENT_ROOT){

			# 1 step
			my $element = {
				rel_path => $r->rel_path,
				abs_path => $r->abs_path,
				rel_loc => $r->rel_loc,
				abs_loc => $r->abs_loc,
				filename => $r->filename,
				filetype => ($r->is_dir ? 'd' : 'f' ),
				ext => $r->ext,
			};

         {
            no warnings;
			   # if we dont eliminate unset ones, HTML::Template will produce errors
			   for (keys %{$element}){
				   $element->{$_}=~/\w/ or delete $element->{$_};
			   }
         };

			unless ($onetime) {
				$element->{'last'} = 1;
				$onetime=1;
			} # indicate this is first element, i know
			# it says last.. thing is we reeverse it for html template.. so that.. anyway.

			push @nav_loop, $element;
			my $abs_next = $r->abs_loc;
 			$r = new File::PathInfo;
			$r->set($abs_next);


		}

		#### @nav_loop

		$self->{_data}->{nav_loop} = [ reverse @nav_loop ];
      # TODO: I keep getting errors here when the array length is 0- errors from
      # HTML Template

	}


	return $self->{_data}->{nav_loop};
}





sub lsd_prepped {
	my $self = shift;
	$self->is_dir or return;
	if ( scalar @{$self->lsd} ){
		my $prepped = [];

		for (@{$self->lsd}){
			push @{$prepped}, {
					filename => $_,
					rel_path => $self->rel_path."/$_",
					rel_loc => $self->rel_path,
					abs_path =>$self->abs_path."/$_",
					abs_loc => $self->abs_path,
					filetype => 'd',
					is_dir => 1,
					is_file => 0,
					is_root => 0,
			};
		}
		return $prepped;
	}
	return [];
}

sub lsf_prepped {
	my $self = shift;
	$self->is_dir or return;
	if (scalar @{$self->lsf}){
		my $prepped = [];

		for (@{$self->lsf}){
			push @{$prepped}, {
				filename => $_,
				rel_path => $self->rel_path."/$_",
				rel_loc => $self->rel_path,
				abs_path =>$self->abs_path."/$_",
				abs_loc => $self->abs_path,
				filetype => 'f',
				is_dir => 0,
				is_file => 1,
				is_root => 0,
			};
		}
		return $prepped;
	}
	return [];
}

sub ls_prepped {
	my $self = shift;
	$self->is_dir or return;

	if (scalar @{$self->ls}){
		my $prepped = [];
		push @{$prepped}, @{$self->lsd_prepped};
		push @{$prepped}, @{$self->lsf_prepped};
		return $prepped;
	}

	return [];
}


## ALL DATA METHODS

sub get_datahash_prepped {
	my $self = shift;
	my $data = $self->get_datahash;
	my $prepped;
	for (keys %{$data}) {
		if(ref $data->{$_} ){ next;}
		defined $data->{$_} or next;
		$data->{$_}=~/\w/ or next;
		$prepped->{$_} = $data->{$_};
	}

	return $prepped;
}



# WHOLE HASH

sub get_datahash{
	my $self = shift;

	my $data = $self->SUPER::get_datahash;

	for (keys %{$self->_network}){
		if (defined $self->_network->{$_}){
			$data->{$_} = $self->_network->{$_};
		}
	}

	for (keys %{$self->_guts}){
		if (defined $self->_guts->{$_}){
			$data->{$_} = $self->_guts->{$_};
		}
	}

	for (keys %{$self->_extended}){
		if (defined $self->_extended->{$_}){
			$data->{$_} = $self->_extended->{$_};
		}
	}

	for (keys %{$self->_more}){
		if (defined $self->_more->{$_}){
			$data->{$_} = $self->_more->{$_};
		}
	}

	return $data;
}




sub elements {
	my $self = shift;
	my @elements = sort keys %{$self->get_datahash};
	return \@elements;
}












# obscure way of getting pathrequest from cgi...
sub _get_rel_path_from_cgi {
	my $self = shift;

	my $req = $self->get_cgi->param($self->{param_name}) or return;

	my $wasfullurl = 0;
	if ($req=~s/^https\:\/\/|^http\:\/\///){
		$wasfullurl++;
	}
	if ($req=~s/^www\.//){
		$wasfullurl++;
	}

	if (my $server = $self->get_cgi->server_name){
		$req=~s/^$server//;
	}

	if ($wasfullurl and !$req){
		return '/';
	}

	$req or return;
	return $req;
}




1;