view release on metacpan or  search on metacpan

lib/CGI/Scriptpaths.pm  view on Meta::CPAN

package CGI::Scriptpaths;
use strict;
use Carp;
use warnings;
use Exporter;

use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
$VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\d+)/g;
@ISA = qw/ Exporter /;
@EXPORT_OK = qw(
abs_cgibin
script_abs_loc
script_abs_path
script_ext
script_filename
script_filename_only
script_rel_loc
script_rel_path
script_is_in_cgibin
script_is_in_DOCUMENT_ROOT
DOCUMENT_ROOT
);
%EXPORT_TAGS = (
   all => \@EXPORT_OK,
);

$CGI::Scriptpaths::DEBUG =0;

sub DEBUG : lvalue { $CGI::Scriptpaths::DEBUG }
sub debug { 
   DEBUG() or return 1; 
   print STDERR __PACKAGE__." @_\n"; 
   return 1; 
}


sub script_abs_loc {
   return _script_abs_loc();
}
sub script_abs_path {
   return _script_abs_path();
}

sub script_rel_path {

   if ( my $docroot = DOCUMENT_ROOT() and my $abs = script_abs_path() ){
      if ( $abs=~s/^$docroot// ){
         return $abs;
      }
      debug('cant get rel path with docroot and abs path set');    
   }

   my $rel = _script_rel_path_last_resort();
   $rel=~s/^\/+//;  
   return "/$rel";
}

sub _script_rel_path_last_resort {
  # my @caller = caller(1);
   #@caller
  # debug("caller @caller \n");
   my $rel = $ENV{SCRIPT_NAME};
   $rel ||= $0;
   defined $rel or return;
        
   if ($rel=~/^\// ){
      # then we cant determine it, because it's absolute      
      debug("path starts with slash [$rel], must be absolute, we cannot determine rel path");
   }
   return "/$rel";
}

sub script_rel_loc {
   my $docroot = DOCUMENT_ROOT() or return;
   my $abs = script_abs_loc() or return;
   $abs=~s/^$docroot// or return;
   return $abs;  
}

sub script_filename {
   my $abs = script_abs_path() or return;
   $abs=~s/^.+\/+//;
   return $abs;   
}

sub script_filename_only {
   my($filename,$ext) = _script_filename() or return;
   return $filename;
}

sub script_ext {
   my($filename,$ext) = _script_filename() or return;   
   defined $ext and defined $filename or return;
   return $ext;
}

sub DOCUMENT_ROOT {
   return _get_docroot();
}

sub abs_cgibin{
   return _get_cgibin();
}

sub script_is_in_cgibin {
   my $abs_script = script_abs_path() or return;
   my $parent     = abs_cgibin() or return;

   require Cwd::Ext;   
   Cwd::Ext::abs_path_is_in($abs_script,$parent) or return 0;
   return 1;   
}

sub script_is_in_DOCUMENT_ROOT {
   my $abs_script = script_abs_path() or return;
   my $parent     = DOCUMENT_ROOT() or return;

   require Cwd::Ext;   
   Cwd::Ext::abs_path_is_in($abs_script,$parent) or return 0;