view release on metacpan or  search on metacpan

lib/Apache2/Translation.pm  view on Meta::CPAN

package Apache2::Translation;

use 5.008008;
use strict;
use warnings;
no warnings qw(uninitialized);

use Apache2::RequestRec ();
use Apache2::RequestUtil ();
use Apache2::RequestIO ();
use Apache2::ServerRec ();
use Apache2::ServerUtil ();
use Apache2::Connection ();
use Apache2::CmdParms ();
use Apache2::Directive ();
use Apache2::Module ();
use Apache2::Log ();
use Apache2::ModSSL ();
use APR::Table ();
use APR::SockAddr ();
use ModPerl::Util ();
use attributes;
use Apache2::Const -compile=>qw{:common :http
				:conn_keepalive
				:methods
				:override
				:satisfy
				:types
				:proxy
				:options
				ITERATE TAKE1 RAW_ARGS RSRC_CONF
				LOG_DEBUG};

our $VERSION = '0.34';

our ($cf,$r,$skip_uri_cut,$m2s,$need_fixup,$need_m2s, %CTX, $ctx);

our ($URI, $REAL_URI, $METHOD, $QUERY_STRING, $FILENAME, $DOCROOT,
     $HOSTNAME, $PATH_INFO, $HEADERS, $REQUEST,
     $C, $CLIENTIP, $KEEPALIVE,
     $MATCHED_URI, $MATCHED_PATH_INFO, $DEBUG, $STATE, $KEY, $RC);

BEGIN {
  package Apache2::Translation::Error;

  use strict;

  sub new {
    my $class=shift;
    bless {@_}=>$class;
  }
}

BEGIN {
  package Apache2::Translation::n;

  use strict;

  sub TIESCALAR {
    my $class=shift;
    bless {@_}=>$class;
  }

  sub STORE {
    my $I=shift;
    $r->notes->{__PACKAGE__."::".$I->{member}}=shift;
  }

  sub FETCH {
    my $I=shift;
    return $r->notes->{__PACKAGE__."::".$I->{member}};
  }
}

BEGIN {
  package Apache2::Translation::_r;

  use strict;

  sub TIESCALAR {
    my $class=shift;
    my %o=@_;
    bless eval("sub {\$r->$o{member}(\@_)}")=>$class;
  }

  sub STORE {my $I=shift; $I->(@_);}
  sub FETCH {my $I=shift; $I->();}
}

tie $URI, 'Apache2::Translation::_r', member=>'uri';
tie $REAL_URI, 'Apache2::Translation::_r', member=>'unparsed_uri';
tie $METHOD, 'Apache2::Translation::_r', member=>'method';
tie $QUERY_STRING, 'Apache2::Translation::_r', member=>'args';
tie $FILENAME, 'Apache2::Translation::_r', member=>'filename';
tie $DOCROOT, 'Apache2::Translation::_r', member=>'document_root';
tie $HOSTNAME, 'Apache2::Translation::_r', member=>'hostname';
tie $PATH_INFO, 'Apache2::Translation::_r', member=>'path_info';
tie $REQUEST, 'Apache2::Translation::_r', member=>'the_request';
tie $HEADERS, 'Apache2::Translation::_r', member=>'headers_in';

tie $C, 'Apache2::Translation::_r', member=>'connection';
tie $CLIENTIP, 'Apache2::Translation::_r', member=>'connection->remote_ip';
tie $KEEPALIVE, 'Apache2::Translation::_r', member=>'connection->keepalive';

tie $MATCHED_URI, 'Apache2::Translation::n', member=>'uri';
tie $MATCHED_PATH_INFO, 'Apache2::Translation::n', member=>'pathinfo';
tie $KEY, 'Apache2::Translation::n', member=>'key';
tie $DEBUG, 'Apache2::Translation::n', member=>'debug';


use constant {
  START      => 0,
  PREPROC    => 1,
  PROC       => 2,
  DONE       => 3,
  LOOKUPFILE => 4,

  LOOKUPFILE_URI => ':LOOKUPFILE:',
  PRE_URI        => ':PRE:',
};

my %states=
  (
   start      => START,
   preproc    => PREPROC,
   proc       => PROC,
   done       => DONE,
   lookupfile => LOOKUPFILE,
  );

my @state_names=qw/start preproc proc done lookupfile/;

my %default_shift=
  (
   &START      => &PREPROC,
   &PREPROC    => &PROC,
   &LOOKUPFILE => &PROC,
   &PROC       => &PROC,
  );

my %next_state=
  (
   &START      => &PREPROC,
   &PREPROC    => &PROC,
   &LOOKUPFILE => &PROC,
   &PROC       => &DONE,
  );

my @directives=
  (
   {
    name         => 'TranslationProvider',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::ITERATE,
    errmsg       => 'TranslationProvider Perl::Class [param1 ...]',
   },
   {
    name         => '<TranslationProvider',
    func         => __PACKAGE__.'::TranslationContainer',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::RAW_ARGS,
    errmsg       => <<'EOF',
<TranslationProvider Perl::Class>