view release on metacpan or  search on metacpan

lib/CAM/App.pm  view on Meta::CPAN

=item computeDir

Returns the directory in which this CGI script is located.  This can
be a class or instance method.

=cut

sub computeDir
{
   my $pkg_or_self = shift;

   my $cgidir;
   if ($ENV{SCRIPT_FILENAME})
   {
      ($cgidir = $ENV{SCRIPT_FILENAME}) =~ s,/[^/\\]*$,,;
   }
   elsif ($ENV{PATH_TRANSLATED})
   {
      $cgidir = $ENV{PATH_TRANSLATED};
   }
   elsif ($ENV{PWD})
   {
      # Append the calling path (if any) to the PWD
      if ($0 =~ /(.*)[\/\\]/)
      {
         my $execpath = $1;
         if ($execpath =~ m,^[/\\],)
         {
            $cgidir = $execpath;
         }
         else
         {
            $cgidir = File::Spec->catdir($ENV{PWD}, $execpath);
         }
      }
      else
      {
         $cgidir = $ENV{PWD};
      }
   }
   # Fix odd cases, like a script called from "./myscript" or "../myscript
   if ($cgidir)
   {
      $cgidir =~ s,/[^/]+/\.\.,,g;    # remove "/dir/.."
      $cgidir =~ s,\\[^\\]+\\\.\.,,g; # remove "\dir\.."
      $cgidir =~ s,/\./,/,g;          # change "path/./path" to "path/path"
      $cgidir =~ s,\\\.\\,\\,g;       # change "path\.\path" to "path\path"
      $cgidir =~ s,/\.$,,g;           # change "path/." to "path"
      $cgidir =~ s,\\\.$,,g;          # change "path\." to "path"
      $cgidir =~ s,//+$,/,g;          # change "path///path" to "path/path"
      $cgidir =~ s,\\\\+$,\\,g;       # change "path\\\path" to "path\path"
   }
   return $cgidir;
}
#--------------------------------#

=item authenticate

Test the login information, if any.  Currently no tests are performed
-- this is a no-op.  Subclasses may override this method to test login
credentials.  Even though it's currently trivial, subclass methods
should alway include the line:

    return undef if (!$self->SUPER::authenticate());

In case the parent authenticate() method adds a test in the future.

=cut

sub authenticate {
   my $self = shift;

   # No checks

   return $self;
}

#--------------------------------#

=item header

Compose and return a CGI header, including the CAM::Session cookie, if
applicable (i.e. if getSession() has been called first).  Returns the
empty string if the header has already been printed.

=cut

sub header {
   my $self = shift;

   my $cgi = $self->getCGI();
   if (!$cgi)
   {
      if (!$self->{header_printed})
      {
         $self->{header_printed} = 1;
         return "Content-Type: text/html\n\n";
      }
      else
      {
         return "";
      }
   }
   elsif (!$cgi->{'.header_printed'})
   {
      if ($self->{session})
      {
         return $cgi->header(-cookie => $self->{session}->getCookie(), @_);
      }
      else
      {
         return $cgi->header(@_);
      }
   }
   else
   {
      return "";
   }
}
#--------------------------------#