view release on metacpan or  search on metacpan

lib/HTML/MasonX/ApacheLikePlackHandler.pm  view on Meta::CPAN

        $defaults{comp_root} = $req->document_root;
    }

    if (exists $allowed_params->{data_dir} and not exists $params{data_dir})
    {
        # constructs path to <server root>/mason
        if (UNIVERSAL::can($APACHE2_SERVERUTIL_CLASS,'server_root')) {
                no strict 'refs';
                $defaults{data_dir} = File::Spec->catdir(&{"$APACHE2_SERVERUTIL_CLASS\::server_root"}(),'mason');
        } else {
                $defaults{data_dir} = Apache->server_root_relative('mason');
        }
        my $def = $defaults{data_dir};
        param_error "Default data_dir (MasonDataDir) '$def' must be an absolute path"
            unless File::Spec->file_name_is_absolute($def);
          
        my @levels = File::Spec->splitdir($def);
        param_error "Default data_dir (MasonDataDir) '$def' must be more than two levels deep (or must be set explicitly)"
            if @levels <= 3;
    }

    # Set default error_format based on error_mode
    if (exists($params{error_mode}) and $params{error_mode} eq 'fatal') {
        $defaults{error_format} = 'line';
    } else {
        $defaults{error_mode} = 'output';
        $defaults{error_format} = 'html';
    }

    # Push $r onto default allow_globals
    if (exists $allowed_params->{allow_globals}) {
        if ( $params{allow_globals} ) {
            push @{ $params{allow_globals} }, '$r';
        } else {
            $defaults{allow_globals} = ['$r'];
        }
    }

    my $self = eval { $class->SUPER::new(%defaults, %params) };

    # We catch this exception just to provide a better error message
    if ( $@ && isa_mason_exception( $@, 'Params' ) && $@->message =~ /comp_root/ )
    {
        param_error "No comp_root specified and cannot determine DocumentRoot." .
                    " Please provide comp_root explicitly.";
    }
    rethrow_exception $@;

    unless ( $self->interp->resolver->can('apache_request_to_comp_path') )
    {
        error "The resolver class your Interp object uses does not implement " .
              "the 'apache_request_to_comp_path' method.  This means that ApacheHandler " .
              "cannot resolve requests.  Are you using a handler.pl file created ".
              "before version 1.10?  Please see the handler.pl sample " .
              "that comes with the latest version of Mason.";
    }

    # If we're running as superuser, change file ownership to http user & group
    if (!($> || $<) && $self->interp->files_written)
    {
        chown $self->get_uid_gid, $self->interp->files_written
            or system_error( "Can't change ownership of files written by interp object: $!\n" );
    }

    $self->_initialize;
    return $self;
}

sub get_uid_gid
{
    # Apache2 lacks $s->uid.
    # Workaround by searching the config tree.
    die "The wrapper layer using the Apache2::Directive class is unimplemented";

    my $conftree = Apache2::Directive::conftree();
    my $user = $conftree->lookup('User');
    my $group = $conftree->lookup('Group');

    $user =~ s/^["'](.*)["']$/$1/;
    $group =~ s/^["'](.*)["']$/$1/;

    my $uid = $user ? getpwnam($user) : $>;
    my $gid = $group ? getgrnam($group) : $);

    return ($uid, $gid);
}

sub _initialize {
    my ($self) = @_;

    if ($self->args_method eq 'mod_perl') {
        unless (defined $APACHE2_REQUEST_CLASS->VERSION) {
            warn "Loading $APACHE2_REQUEST_CLASS at runtime.  You could " .
                 "increase shared memory between Apache processes by ".
                 "preloading it in your httpd.conf or handler.pl file\n";
            eval "require $APACHE2_REQUEST_CLASS";
        }
    } else {
        unless (defined CGI->VERSION) {
            warn "Loading CGI at runtime.  You could increase shared ".
                 "memory between Apache processes by preloading it in ".
                 "your httpd.conf or handler.pl file\n";

            require CGI;
        }
    }

    # Add an HTML::Mason menu item to the /perl-status page.
    if (defined $APACHE2_STATUS_CLASS->VERSION) {
        # A closure, carries a reference to $self
        my $statsub = sub {
            my ($r,$q) = @_; # request and CGI objects
            return [] if !defined($r);

            if ($r->path_info and $r->path_info =~ /expire_code_cache=(.*)/) {
                $self->interp->delete_from_code_cache($1);
            }

            return ["<center><h2>" . $self->apache_status_title . "</h2></center>" ,
                    $self->status_as_html(apache_req => $r),
                    $self->interp->status_as_html(ah => $self, apache_req => $r)];