File Coverage

blib/lib/Apache/Scriptor.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

package Apache::Scriptor;
$VERSION="1.21";
use CGI::WebOut;
use Cwd;

# constructor new()
# Ñîçäàåò íîâûé Apache::Scriptor-îáúåêò.
sub new
{ my ($class)=@_;
  my $this = {
    Handlers        => {},
    HandDir         => ".",
    htaccess        => ".htaccess",
    # Çàïîìèíàåì, êàêîé çàïðîñ â äåéñòâèòåëüíîñòè áûë âûïîëíåí, ÷òîáû
    # ïîòîì èñêàòü åãî â htaccess-àõ.
    self_scriptname => $ENV{SCRIPT_NAME}
  };
  return bless($this,$class);
}


# void set_handlers_dir(string $dir)
# Óñòàíàâëèâàåò äèðåêòîðèþ äëÿ ïîèñêà îáðàáîò÷èêîâ.
sub set_handlers_dir
{ my ($this,$dir)=@_;
  $this->{HandDir}=$dir;
}

# void addhandler(ext1=>[h1, h2,...], ext2=>[...])
# Óñòàíàâëèâàåò îáðàáîò÷èê(è) äëÿ ðàñøèðåíèé ext1 è ext2.
# Çäåñü h1, h2 è ò.ä. ïðåäñòàâëÿþò ñîáîé ÑÑÛËÊÈ íà ôóíêöèè-îáðàáîò÷èêè.
# Åñëè æå îíè çàäàíû íå êàê ññûëêè, à êàê ÑÒÐÎÊÈ, òî â ìîìåíò îáðàùåíèÿ
# ê î÷åðåäíîìó îáðàáîò÷èêó ïðîèçâîäèòñÿ ïîïûòêà åãî çàãðóçèòü èç ôàéëà,
# èìÿ êîòîðîãî ñîâïàäàåò ñ èìåíåì îáðàáîò÷èêà ñ ðàñøèðåíèåì ".pl" èç
# äèðåêòîðèè, êîòîðàÿ çàäàíà âûçîâîì set_handlers_dir().
sub addhandler
{ my ($this,%hands)=@_;
  %{$this->{Handlers}}=(%{$this->{Handlers}},%hands);
  return;
}

# void pushhandler(string ext, func &func)
# Äîáàâëÿåò îáðàáîò÷èê äëÿ ðàñøèðåíèÿ ext â êîíåö ñïèñêà îáðàáîò÷èêîâ.
sub pushhandler
{ my ($this,$ext,$func)=@_;
  $this->{Handlers}{$ext}||=[];
  push(@{$this->{Handlers}{$ext}},$func);
  return;
}

# void removehandler(ext1, ext2, ...)
# Óäàëÿåò îáðàáîò÷èê(è) äëÿ ðàñøèðåíèé ext1 è ext2.
sub removehandler
{ my ($this,@ext)=@_;
  foreach (@ext) { delete $this->{Handlers}{$_} }
  return;
}

# void set_404_url($url)
# Óñòàíàâëèâàåò àäðåñ ñòðàíèöû 404-é îøèáêè, íà êîòîðóþ áóäåò ïðîèçâåäåí
# ðåäèðåêò, åñëè ôàéë íå íàéäåí.
sub set_404_url
{ my ($th,$url)=@_;
  $th->{404}=$url;
}

# void set_htaccess_name($name)
# Óñòàíàâëèâàåò èìÿ htaccess-ôàéëà. Ïî óìîë÷àíèþ ýòî .htaccess.
sub set_htaccess_name
{ my ($th,$htaccess)=@_;
  $th->{htaccess}=$htaccess;
}

sub process_htaccess
{ my ($th,$fname)=@_;
  open(local *F,$fname) or return;
  # Ñíà÷àëà ñîáèðàåì âñå äèðåêòèâû èç .htaccess
  my %Action=();
  my @AddHandler=();
  while(!eof(F)) {
    my $s=; $s=~s/^\s+|#.*|\s+$//sg; next if $s eq "";
    # Äèðåêòèâà Action
    if($s=~m/Action\s+([\w\d-]+)\s*"?([^"]+)"?/si) {
      $Action{$1}=1 if $2 eq $th->{self_scriptname};
    }
    # Äèðåêòèâà AddHandler
    if($s=~m/AddHandler\s+([\w\d-]+)\s*(.+)/si) {
      push @AddHandler, [ $1, [ map { s/^\s*\.?|\s+$//sg; $_?($_):() } split /\s+/, $2 ] ];
    }
    # Äèðåêòèâà ErrorDocument 404
    if($s=~/ErrorDocument\s+404\s+"?([^"]+)"?/si) {
      $th->set_404_url($1);
    }
  }
  # Çàòåì äîáàâëÿåì öåïî÷êè îáðàáîò÷èêîâ
  my %ProcessedExt=();
  foreach my $info (@AddHandler) {
    my ($hand,$ext)=@$info;
    # Ñðàçó îòìåòàåì îáðàáîò÷èêè, êîòîðûå ÍÅ óêàçûâàþò íà Apache::Scriptor.
    # Ìû íå ìîãëè ýòîãî ñäåëàòü â âåðõíåì öèêëå, ïîòîïìó ÷òî äèðåêòèâû
    # Action è AddHandler ìîãóò èäòè íå ïî ïîðÿäêó.
    next if !$Action{$hand};
    # Äîáàâëÿåì äëÿ êàæäîãî ðàñøèðåíèÿ îáðàáîò÷èê â öåïî÷êó
    foreach my $ext (@$ext) {
      # Åñëè ýòî ðàñøèðåíèå âñòðå÷àåòñÿ â òåêóùåì htaccess-ôàéëå
      # âïåðâûå, ýòî çíà÷èò, ÷òî íà÷àòà î÷åðåäíàÿ öåïî÷êà îáðàáîò÷èêîâ.
      #  ýòîì ñëó÷àå íóæíî óäàëèòü óæå èìåþùóþñÿ öåïî÷êó.
      if(!$ProcessedExt{$ext}) {
        $th->removehandler($ext);
        $ProcessedExt{$ext}=1;
      }
      # Çàòåì ñïîêîéíî âûçûâàåì pushhandler()
      $th->pushhandler($ext,$hand);
    }
  }
}

sub process_htaccesses
{ my ($th,$path)=@_;
  # Ñíà÷àëà îïðåäåëÿåì âñå ïîëíûå ïóòè ê htaccess-ôàéëàì
  my @Hts=();
  while($path=~m{[/\\]}) {
    if(-d $path) {
      my $ht="$path/$th->{htaccess}";
      unshift(@Hts,$ht) if -f $ht;
    }
    $path=~s{[/\\][^/\\]*$}{}s;
  }
  # Çàòåì îáðàáàòûâàåì ýòè ôàéëû, íà÷èíàÿ ñ ñàìîãî êîðíåâîãî
  map { $th->process_htaccess($_) } @Hts;
}

# void run_uri(string $uri [,string $path_translated])
# Çàïóñêàåò óêàçàííûé URI íà îáðàáîòêó. Åñëè óêàçàí ïàðàìåòð $path_translated,
# òî îí ñîäåðæèò ïîëíîå èìÿ ôàéëà ñ ñîäåðæèìûì äëÿ îáðàáîòêè. Â ïðîòèâíîì
# ñëó÷àå èìÿ ôàéëà âû÷èñëÿåòñÿ àâòîìàòè÷åñêè íà îñíîâå $uri (ýòî íå âñåãäà
# ðàáîòàåò ïðàâèëüíî - íàïðèìåð, òàêàÿ øòóêà íå ïðîéäåò, åñëè äèðåêòîðèÿ áûëà
# çàâåäåíà êàê Alias Apache).
sub run_uri
{ my ($this,$uri,$path)=@_;
  Header("X-Powered-by: Apache::Scriptor v$VERSION. (C) Dmitry Koterov ") if !$CopySend++;

  # Òåïåðü ðàáîòàåì ñ ÊÎÏÈÅÉ îáúåêòà. Òàêèì îáðàçîì, äàëüíåéøèå âûçîâû
  # process_htaccesses è ò.ä. íå îòðàçÿòñÿ íà îáùåì ñîñòîÿíèè îáúåêòà
  # ïîñëå îêîí÷àíèÿ çàïðîñà.
  local $this->{Handlers}={%{$this->{Handlers}}};
  local $this->{404}=$this->{404};

  # Ðàçäåëÿåì íà URL è QUERY_STRING
  local ($ENV{SCRIPT_NAME},$q) = split /\?/, $uri, 2;
  $ENV{QUERY_STRING}=defined $q? $q : "";

  # Âû÷èñëÿåì ïóòü ê ôàéëó ñêðèïòà ïî URI
  if(!$path) {
    $path="$ENV{DOCUMENT_ROOT}$ENV{SCRIPT_NAME}";
  }

  # Ãîòîâèì íîâûå ïåðåìåííûå îêðóæåíèÿ, ÷òîáû ñêðûòü Apache::Scriptor;
  local $ENV{REQUEST_URI}     = $uri;
  local $ENV{SCRIPT_FILENAME} = $path;
  local $ENV{REDIRECT_URL};     delete($ENV{REDIRECT_URL});
  local $ENV{REDIRECT_STATUS};  delete($ENV{REDIRECT_STATUS});
  # Ìåíÿåì òåêóùóþ äèðåêòîðèþ.
  my $MyDir=getcwd();
  ($MyDir) = $MyDir=~/(.*)/;
  my ($dir) = $path; $dir=~s{(.)[/\\][^/\\]*$}{$1}sg;

  chdir($dir); getcwd(); # getcwd: Ñáðàñûâàåò $ENV{PWD}. Íàì ýòî íàäî? Ôèã çíàåò...
  # Îáðàáàòûâàåì ôàéëû .htaccess.
  $this->process_htaccesses($path);

  # Âñå. Òåïåðü ñîñòîÿíèå ïåðåìåííûõ ñêðèïòà òàêîå æå, êàê ó ñòðàíèöû,
  # êîòîðàÿ â äàëüíåéøåì ïîëó÷èò óïðàâëåíèå. Çàïóñêàåì îáðàáîò÷èêè.
  $this->__run_handlers();

  # Âîññòàíàâëèâàåì òåêóùóþ äèðåêòîðèþ
  chdir($MyDir); getcwd();
}


# Âíóòðåííÿÿ ôóíêöèÿ - çàïóñêàåò îáðàáîò÷èêè äëÿ ôàéëà, êîòîðûé çàäàí â %ENV.
# Âûçûâàåòñÿ Â ÊÎÍÒÅÊÑÒÅ ÝÒÎÃÎ ÔÀÉËÀ (òî åñòü, %ENV íàõîäèòñÿ â òàêîì æå ñîñòîÿíèè,
# êàê ïîñëå îáÿ÷íîãî çàïóñêà ñêðèïòà Àïà÷åì, è òåêóùàÿ äèðåêòîðèÿ ñîîòâåòñòâóåò
# äèðåêòîðèè ñî ñòðàíèöåé).
sub __run_handlers
{ my ($th)=@_;
  # ðàñøèðåíèå ôàéëà
  my ($ext)  = $ENV{SCRIPT_FILENAME}=~m|\.([^.]*)$|; if(!defined $ext) { $ext=""; }

  # âûáèðàåì ñïèñîê îáðàáîò÷èêîâ äëÿ ýòîãî ðàñøèðåíèÿ
  $th->{Handlers}{$ext}
    or die "$ENV{SCRIPT_NAME}: could not find handlers chain for extension \"$ext\"\n";

  # âõîäíîé áóôåð (âíà÷àëå â íåì ñîäåðæèìîå ôàéëà, åñëè äîñòóïíî)
  my $input="";
  if(open(local *F, $ENV{SCRIPT_FILENAME})) { local ($/,$\); binmode(F); $input=; }

  # ïðîõîäèìñÿ ïî âñåì îáðàáîò÷èêàì
  my $next=1; # íîìåð ñëåäóþùåãî îáðàáîò÷èêà
  my @hands=@{$th->{Handlers}{$ext}};
  NoAutoflush() if @hands>1;
  foreach my $hand (@hands)
  { # Îáúåêò ïåðåíàïðàâëåíèÿ âûâîäà. Åñëè ó íàñ âñåãî îäèí îáðàáîò÷èê, òî
    # ïåðåíàïðàâëÿòü âûâîä íå ïîòðåáóåòñÿ. Èíà÷å - ïîòðåáóåòñÿ, ÷òî è äåëàåòñÿ
    my $OutObj=$hands[$next++]? CGI::WebOut->new : undef;
    my $func=$hand; # óêàçàòåëü íà ôóíêöèþ
    # Ïðîâåðÿåì - íóæíî ëè çàãðóçèòü îáðàáîò÷èê?
    if((ref($func)||"") ne "CODE") {
      # ïåðåêëþ÷àåì ïàêåò
      package Apache::Scriptor::Handlers;
      # îáðàáîò÷èêà åùå íåò â ýòîì ïàêåòå?
      if(!*{$func}{CODE}) {
        my $hname="$th->{HandDir}/$func.pl";
        -f $hname or die "$ENV{SCRIPT_NAME}: could not load the file $hname for handler $hand\n";
        do "$hname";
        *{$func}{CODE} or die "$ENV{SCRIPT_NAME}: cannot find handler $hand in $hname after loading $hname\n";
      }
      # ïîëó÷àåì óêàçàòåëü íà ôóíêöèþ îáðàáîò÷èêà
      local $this=$th;
      $func=*{$func}{CODE};
    }
    # Ôóíêöèÿ îáðàáîò÷èêà ïðèíèìàåò ïàðàìåòð: âõîäíîé áóôåð.
    # Åå çàäà÷à - îáðàáîòàòü åãî è, èñïîëüçóÿ print, ïðîïå÷àòàòü ðåçóëüòàò.
    #  ñëó÷àå îøèáêè (ôàéë íå íàéäåí) ôóíêöèÿ äîëæíà âîçâðàòèòü -1!
    my $result=&$func($input);
    if($result eq "-1") {
      if($th->{404} && $th->{404} ne $th->{self_scriptname}) {
        Redirect($th->{404});
        exit;
      } else {
        die "$hand: could not find the file $ENV{SCRIPT_FILENAME}\n";
      }
    }

    # Òî, ÷òî ïîëó÷èëîñü, êëàäåì âî âõîäíîé áóôåð äëÿ ñëåäóþùåãî îáðàáîò÷èêà.
    # Åñëè âûâîä íå ïåðåíàïðàâëÿëñÿ, òî êëàäåì òóäà "".
    $input=$OutObj?$OutObj->buf:"";
  }
  # Îêîí÷àòåëüíûé ðåçóëüòàò îêàæåòñÿ âî âõîäíîì áóôåðå (êàê áóäòî ãîòîâûé äëÿ
  # ñëåäóþùåãî îáðàáîò÷èêà, êîòîðîãî íåò). Åãî-òî ìû è âûâîäèì â áðàóçåð.
  print $input;
}



package Apache::Scriptor::Handlers;
use CGI::WebOut;
#  ýòîì ïàêåòå ïåðå÷èñëÿþòñÿ ñòàíäàðòíûå îáðàáîò÷èêè,
# êîòîðûå, ñêîðåå âñåãî, áóäóò èñïðîëüçîâàíû â ïåðâóþ î÷åðåäü.
# Èìåííî â ýòîò ïàêåò ïîïàäàþò îáðàáîò÷èêè, çàãðóæåííûå àâòîìàòè÷åñêè.

# Îáðàáîò÷èê ïî óìîë÷àíèþ - ïðîñòî âûâîäèò òåêñò
sub default
{ my ($input,$fname)=@_;
  -f $ENV{SCRIPT_FILENAME} or return -1;
  CGI::WebOut::Header("Content-type: text/html");
  print $input;
}

# Îáðàáîò÷èê perl-ñêðèïòîâ. Ïîäðàçóìåâàåòñÿ, ÷òî âûâîä ñêðèïòà èäåò ÷åðåç print.
sub perl
{ my ($input)=@_;
  -f $ENV{SCRIPT_FILENAME} or return -1;
  eval("\n#line 1 \"$ENV{SCRIPT_NAME}\"\npackage main; $input");
}

return 1;
__END__