/usr/local/CPAN/CGI-PathRequest/CGI/PathRequest.pm

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 = <INPUT>;
			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;