view release on metacpan or  search on metacpan

uHTML/request.pm  view on Meta::CPAN

#
# Author: Roland Mosler - Roland@Place.Ug
#
# Das ist eine uHTML-Bibliothek von Place.Ug
# Es ist erlaubt dieses Paket unter der GPLv3 zu nutzen
# Bei Weiterentwicklungen ist die Ursprungsbibliothek zu nennen
#
# Fehler und Verbesserungen bitte an uHTML@Place.Ug
#
# This is a uHTML library from Place.Ug
# It is allowed to use this library under the GPLv3
# The name of this library is to be named in all derivations
#
# Please report errors to uHTML@Place.Ug
#
# © Roland Mosler, Place.Ug
#


use strict ;

package uHTML::request ;

use version ; our $VERSION = "1.83" ;

require uHTML ;
use LWP::MediaTypes ;
use URI::Escape ;
use IO::Handle ;
use Time::Local( 'timegm','timelocal_nocheck' ) ;
use POSIX qw( strftime setlocale LC_TIME ) ;

my( @initRequest, @finishRequest ) ;

my @Empty = () ;

sub new
{
  my $class   = shift ;
  my $env     = shift ;
  my $req ;

  unless( ref $env eq 'HASH' )
  {
    my %E = %ENV ;
    $env = \%E ;
  }

  $env->{'PATH_INFO'}     =~ s%/*$%% ;
  $req->{'ENV'}           = $env ;
  $req->{'charset'}       = 'utf-8' ;
  $req->{'home'}          = $env->{'DATA_ROOT'} ? $env->{'DATA_ROOT'} : $env->{'SCRIPT_ROOT'} ;
  $req->{'Root'}          = $env->{'DOCUMENT_ROOT'} ;
  $req->{'Root'}         .= $env->{'REDIRECT_ROOT'} if $env->{'REDIRECT_ROOT'}  ;

  my $ru                  = $env->{'REQUEST_URI'} =~ s/\?.*//r ;
  $req->{'Request'}       = [ split m%/+%,$ru,-1 ] ;
  $req->{'Path'}          = [ split m%/+%,$env->{'PATH_INFO'},-1 ] ;
  $req->{'file'}          = $req->{'Root'} . $env->{'PATH_INFO'} ;

  if( -d $req->{'file'} )
  {
    $req->{'file'}       .= '/index.uhtml' ;
    $req->{'File'}        = 'index.uhtml' ;
    $req->{'RequestFile'} = 'index.uhtml';
  }
  else
  {
    $req->{'File'}        = pop @{$req->{'Path'}} ;
    $req->{'RequestFile'} = pop @{$req->{'Request'}} ;
  }

  $req->{'BaseName'}      = $req->{'File'} =~ s/\.[^\.]*$//ir ;
  $req->{'RequestName'}   = $req->{'RequestFile'} =~ s/\.[^\.]*$//ir ;
  $req->{'path'}          = join '/',@{$req->{'Path'}} ;
  $req->{'Path'}->[0]     = $env->{'HOST_NAME'} ? $env->{'HOST_NAME'} : $env->{'SERVER_NAME'} ;
  $req->{'request'}       = join '/'.@{$req->{'Request'}} ;
  $req->{'Request'}->[0]  = $env->{'HTTP_HOST'} ;

  return( $env->{'uRequest'} = bless( $req,$class ) ) ;
}

sub Init
{
  my $self = shift ;

  if( @_ )
  {
    my $func ;

    foreach $func( @_ )
    {
      next if ref $func ne 'CODE' ;
      next if grep $func == $_,@initRequest ;
      push @initRequest,$func ;
    }
  }
  elsif( ref $self eq 'uHTML::request' and not $self->{'InitRequest'} )
  {
    uHTML::loadModules( $self->{'ENV'} ) ;
    my @icopy = @initRequest ;  # side effect protection
    $_->($self) foreach @icopy ;
    $self->{'InitRequest'} = 1 ;
  }
  return $self ;
}

sub Finish
{
  my $self = shift ;

  if( @_ )
  {
    my $func ;

    foreach $func( @_ )
    {
      next if ref $func ne 'CODE' ;

uHTML/request.pm  view on Meta::CPAN

  uHTML::fileEnd() ;
}

sub HTML
{
  my $self   = shift ;
  my $string = shift ;

  $self->codeFile() unless $self->{'length'} ;        # process uHTML to HTML
  return( $string ? join( '',@{$self->{'HTML'}} ) : $self->{'HTML'} ) ;
}

sub putFile
{
  my $self = shift ;

  $self->FileData() unless $self->{'FileData'} ;
  $self->codeFile() unless $self->{'length'} ;        # process uHTML to HTML
  print foreach $self->{'HTML'} ? @{$self->{'HTML'}} : $self->{'FileData'} ;
}

sub process
{
  my $self = shift ;
  my $env  = shift ;

  $self = uHTML::request->new( $env ) unless ref $self eq 'uHTML::request'; # get a new uHTML::request if needed
#   $self->Init() ; # Initialise the request and call all init functions
#   $self->codeFile() ; # process uHTML to HTML
#   $self->Finish() ; #Close the request call all closing functions
  $self->putHeader() ; # Send out headers
  $self->putFile() ;   # Send out HTML
}

sub home
{
  my $self = shift ;

  return $self->{'home'} ;
}


sub file
{
  my $self = shift ;

  return $self->{'file'} ;
}

sub File
{
  my $self  = shift ;
  my $fname = shift ;

  if( $fname )
  {
    $fname = "/${\($self->Path())}/$fname" unless $fname =~ m%^/% ;
    if( -f "${\($self->Root())}$fname" )
    {
      my $p0               = $self->{'Path'}->[0] ;
      $self->{'Path'}      = [ split m%/+%,$fname,-1 ] ;
      $self->{'File'}      = pop @{$self->{'Path'}} ;
      $self->{'BaseName'}  = $self->{'File'} =~ s/\.[^\.]*$//ir ;
      $self->{'path'}      = join '/',@{$self->{'Path'}} ;
      $self->{'file'}      = "${\($self->Root())}$self->{'path'}/$self->{'File'}" ;
      $self->{'Path'}->[0] = $p0 ;
    }
  }

  return $self->{'File'} ;
}

sub BaseName
{
  my $self = shift ;
  return $self->{'BaseName'} ;
}

sub RequestName
{
  my $self = shift ;
  return $self->{'RequestName'} ;
}

sub Path
{
  my $self = shift ;
  my $idx  = shift ;

  return $self->{'Path'}->[$idx] if $idx =~ m/^\d+$/ ;
  return (wantarray ? @{$self->{'Path'}}[$1 .. $2] : join '/',@{$self->{'Path'}}[$1 .. $2]) if $idx =~ m/^(\d+)(?:-|\.\.)(\d+)$/ ;
  return (wantarray ? @{$self->{'Path'}} : $self->{'path'}) ;
}

sub RequestPath
{
  my $self = shift ;
  my $idx  = shift ;

  return $self->{'Request'}->[$idx] if $idx =~ m/^\d+$/ ;
  return (wantarray ? @{$self->{'Request'}}[$1 .. $2] : join '/',@{$self->{'Request'}}[$1 .. $2]) if $idx =~ m/^(\d+)(?:-|\.\.)(\d+)$/ ;
  return (wantarray ? @{$self->{'Request'}} : $self->{'request'}) ;
}

sub Root
{
  my $self = shift ;

  $self->{'Root'} = shift if @_ ;
  return $self->{'Root'} ;
}

sub ServerPath
{
  my $self = shift ;
  my $Path = shift ;

  return $self->Root() unless $Path ne '' ;
  return( $Path=~s/^#// ? ($self->{'home'} && $Path !~ m%^/% ? "$self->{'home'}/$Path" : $Path) :
                          ($self->{'Root'}.(  $Path !~ m%^/% ? "$self->{'path'}/$Path" : $Path)) ) ;
}