File Coverage

blib/lib/OpenInteract2/Context.pm

Criterion	Covered	Total	%
statement	24	368	6.5
branch	0	134	0.0
condition	0	87	0.0
subroutine	8	73	10.9
pod			n/a
total	32	662	4.8

package OpenInteract2::Context;

# $Id: Context.pm,v 1.87 2005/03/17 14:57:57 sjn Exp $

use strict;
use base                     qw( Exporter Class::Accessor::Fast );
use Data::Dumper             qw( Dumper );
use DateTime;
use Log::Log4perl            qw( get_logger );
use OpenInteract2::Constants qw( :log );
use OpenInteract2::Log       qw( uchk );

$OpenInteract2::Context::VERSION   = sprintf("%d.%02d", q$Revision: 1.87 $ =~ /(\d+)\.(\d+)/);

use constant DEFAULT_TEMP_LIB_DIR => 'templib';

my ( $log_spops, $log_act, $log_init );

sub version { return '1.99_06' }

# Exportable deployment URL call -- main, images, static

my ( $DEPLOY_URL, $DEPLOY_IMAGE_URL, $DEPLOY_STATIC_URL );
sub DEPLOY_URL        { return $DEPLOY_URL }
sub DEPLOY_IMAGE_URL  { return $DEPLOY_IMAGE_URL }
sub DEPLOY_STATIC_URL { return $DEPLOY_STATIC_URL }

my ( $DEFAULT_LANGUAGE_HANDLE );

# This is the only copy of the context that should be around. We might
# modify this later so we can have multiple copies of the context
# around (produced by, say, a ContextFactory), but W(P)AGNI. Note that
# before accessing the exported variable you should first ensure that
# it's initialized.

my ( $CTX );
sub CTX { return $CTX }

@OpenInteract2::Context::EXPORT_OK = qw(
     CTX DEPLOY_URL DEPLOY_IMAGE_URL DEPLOY_STATIC_URL
);

require OpenInteract2::Config;
require OpenInteract2::Config::Bootstrap;
require OpenInteract2::DatasourceManager;
require OpenInteract2::Observer;
require OpenInteract2::Request;
require OpenInteract2::Response;
require OpenInteract2::Action;
require OpenInteract2::Controller;
require OpenInteract2::Exception;
require OpenInteract2::Setup;
require OpenInteract2::I18N;

my @CORE_FIELDS    = qw( bootstrap repository packages cache
                         datasource_manager timezone timezone_object setup_class );
my @REQUEST_FIELDS = qw( request response controller user group is_logged_in is_admin );
__PACKAGE__->mk_accessors( @CORE_FIELDS, @REQUEST_FIELDS );

########################################
# CONSTRUCTOR AND INITIALIZATION

# $item should be either a hashref of parameters (preferably with one
# parameter 'website_dir') or an OI2::Config::Bootstrap object

sub create {
    my ( $class, $item, $params ) = @_;
    return $CTX if ( $CTX );
    $item   ||= {};
    $params ||= {};

    my ( $website_dir );

    # Don't assign this to $CTX until after it's setup!
    my $ctx = bless( {}, $class );

    my ( $bootstrap );
    if ( ref $item eq 'OpenInteract2::Config::Bootstrap' ) {
        $bootstrap   = $item;
        $website_dir = $bootstrap->website_dir;
    }
    elsif ( $item->{website_dir} ) {
        $bootstrap = eval {
            OpenInteract2::Config::Bootstrap->new({
                website_dir => $item->{website_dir}
            })
        };
        if ( $@ ) {
            OpenInteract2::Exception->throw(
                     "Cannot create bootstrap object using website ",
                     "directory '$item->{website_dir}': $@" );
        }
        $website_dir = $item->{website_dir};
    }

    # this is typically only set from standalone scripts; see POD

    if ( $params->{initialize_log} and -d $website_dir ) {
        OpenInteract2::Log->init_from_website( $website_dir );
    }
    elsif ( $params->{initialize_log} ) {
        OpenInteract2::Log->init_screen;
    }

    $log_init ||= get_logger( LOG_INIT );

    if ( $bootstrap ) {
        $ctx->bootstrap( $bootstrap );
        $log_init->is_debug &&
            $log_init->debug( "Assigned bootstrap ok; setting up..." );
        eval { $ctx->setup( $params ) };
        if ( $@ ) {
            my $error = $@;
            $CTX = undef;
            $log_init->error( "Setup failed to run: $error" );
            OpenInteract2::Exception->throw( $error );
        }
        else {
            $log_init->is_info && $log_init->info( "Setup ran ok" );
        }
    }
    return $CTX = $ctx
}


sub instance {
    my ( $class, $no_exception ) = @_;
    return $CTX if ( $CTX );
    if ( $no_exception ) {
        return undef;
    }
    OpenInteract2::Exception->throw(
        "No context available; first call 'create()'" );
}


# Initialize the Context

sub setup {
    my ( $self, $params ) = @_;
    $params ||= {};

    my @skip = ();
    if ( $params->{skip} ) {
        if ( ref $params->{skip} eq 'ARRAY' ) {
            push @skip, @{ $params->{skip} };
        }
        else {
            push @skip, $params->{skip};
        }
        $log_init->info( "Will skip setup tasks: ", join( ', ', @skip ) );
    }
    my $bootstrap = $self->bootstrap;
    unless ( $bootstrap and
             ref( $bootstrap ) eq 'OpenInteract2::Config::Bootstrap' ) {
        $log_init->error( "Cannot run setup() without bootstrap defined" );
        OpenInteract2::Exception->throw(
            "Cannot run setup() on context without a valid ",
            "bootstrap configuration object set" );
    }

    # This should call _initialize_singleton() when it's got the
    # context in a decent state...

    $log_init->info( "Running setup actions..." );
    OpenInteract2::Setup->run_all_actions( $self, @skip );
    $log_init->info( "Setup actions ran ok, context now initialized" );

    return $self;
}


# Called from OI2::Setup after it's read the server configuration
sub _initialize_singleton {
    my ( $self ) = @_;
    $CTX = $self;
}


########################################
# CONFIGURATION ASSIGNMENTS
#
# These subroutines generally map to some basic system information
# that can be modified at runtime in addition to the modifications in
# the configuration. Note: modifications made here should get
# reflected in the configuration as well.

sub server_config {
    my ( $self, $config ) = @_;
    if ( $config ) {
        $log_init ||= get_logger( LOG_INIT );
        $config->{dir}{website} = $self->bootstrap->website_dir;
        $config->translate_dirs;
        $log_init->info( "Translated server config directories ok" );

        $self->{server_config} = $config;
        $self->assign_deploy_url;
        $self->assign_deploy_image_url;
        $self->assign_deploy_static_url;
        $log_init->info( "Assigned constants from server config ok" );
    }
    return $self->{server_config};
}

# Where is this app deployed under?

sub assign_deploy_url {
    my ( $self, $url ) = @_;

    $url ||= $self->server_config->{context_info}{deployed_under};
    $url = $self->_clean_deploy_url( $url );
    if ( $url and $url !~ m|^/| ) {
        OpenInteract2::Exception->throw(
            "Deployment URL must begin with a '/'. It may not ",
            "be a fully-qualified URL (e.g., 'http://foo.com/') ",
            "and it may not be a purely relative URL (e.g., 'oi')" );
    }
    $DEPLOY_URL = $url;
    $self->server_config->{context_info}{deployed_under} = $url;
    $log_init->is_info && $log_init->info( "Assigned deployment URL '$url'" );
    return $DEPLOY_URL;
}

sub assign_deploy_image_url {
    my ( $self, $url ) = @_;

    $url ||= $self->server_config->{context_info}{deployed_under_image};
    $url = $self->_clean_deploy_url( $url );
    $DEPLOY_IMAGE_URL = $url;
    $self->server_config->{context_info}{deployed_under_image} = $url;
    $log_init->is_info &&
        $log_init->info( "Assigned image deployment URL '$url'" );
    return $DEPLOY_IMAGE_URL;
}

sub assign_deploy_static_url {
    my ( $self, $url ) = @_;

    $url ||= $self->server_config->{context_info}{deployed_under_static};
    $url = $self->_clean_deploy_url( $url );
    $DEPLOY_STATIC_URL = $url;
    $self->server_config->{context_info}{deployed_under_static} = $url;
    $log_init->is_info &&
        $log_init->info( "Assigned static deployment URL '$url'" );
    return $DEPLOY_STATIC_URL;
}

sub _clean_deploy_url {
    my ( $self, $url ) = @_;
    return '' unless ( $url );
    $url =~ s/^\s+//;
    $url =~ s/\s+$//;
    $url =~ s|/$||;
    return $url;
}

# What type of requests/responses are we getting/generating?


# TODO: get rid of 'context_info' reference; these are strictly
# assigned by adapter now

sub assign_request_type {
    my ( $self, $type ) = @_;

    $type ||= $self->server_config->{context_info}{request};
    $self->server_config->{context_info}{request} = $type;
    OpenInteract2::Request->set_implementation_type( $type );
    $log_init->is_info &&
        $log_init->info( "Assigned request type '$type'" );
}


sub assign_response_type {
    my ( $self, $type ) = @_;

    $type ||= $self->server_config->{context_info}{response};
    $self->server_config->{context_info}{response} = $type;
    OpenInteract2::Response->set_implementation_type( $type );
    $log_init->is_info &&
        $log_init->info( "Assigned response type '$type'" );
}


########################################
# DATE FACTORY

sub create_date {
    my ( $self, $params ) = @_;
    $params ||= {};
    if ( $params->{epoch} ) {
        return DateTime->from_epoch(
            time_zone => $self->timezone_object,
            epoch     => $params->{epoch},
        );
    }
    elsif ( $params->{last_day_of_month} ) {
        delete $params->{last_day_of_month};
        return DateTime->last_day_of_month(
            time_zone => $self->timezone_object,
            %{ $params },
        );
    }
    elsif ( $params->{year} ) {
        return DateTime->new(
            time_zone => $self->timezone_object,
            %{ $params }
        );
    }
    else {
        return DateTime->now(
            time_zone => $self->timezone_object
        );
    }
}


########################################
# ACTION LOOKUP

sub lookup_action_name {
    my ( $self, $action_url ) = @_;
    $log_act ||= get_logger( LOG_ACTION );
    unless ( $action_url ) {
        OpenInteract2::Exception->throw(
            "Cannot lookup action without action name without URL" );
    }
    $log_act->is_debug &&
        $log_act->debug( "Try to find action name for URL '$action_url'" );
    my $server_config = $self->server_config;
    my $action_name = $server_config->{action_url}{ $action_url } || '';
    $log_act->is_debug &&
        $log_act->debug( "Found name '$action_name' for URL '$action_url'" );
    return $action_name;
}


sub lookup_action_info {
    my ( $self, $action_name ) = @_;
    $log_act ||= get_logger( LOG_ACTION );
    unless ( $action_name ) {
        $log_act->error( "No action name given to lookup info; called ",
                         "from: ", join( ' | ', caller ) );
        OpenInteract2::Exception->throw(
            "Cannot lookup action without action name" );
    }

    $log_act->is_debug &&
        $log_act->debug( "Try to find action info for '$action_name'" );
    my $server_config = $self->server_config;
    my $action_info = $server_config->{action}{ lc $action_name };

    # Let the caller deal with a not found action rather than assuming
    # we know best.

    unless ( $action_info ) {
        my $msg = "Action '$action_name' not found in action table" ;
        $log_act->error( $msg );
        OpenInteract2::Exception->throw( $msg );
    }

    $log_act->is_debug &&
        $log_act->debug( uchk( "Action '%s' is [Class: %s] [Template: %s] ",
                               $action_name, $action_info->{class},
                               $action_info->{template} ) );

    # Allow as many redirects as we need

    my $current_name = $action_name;
    while ( my $action_redir = $action_info->{redir} ) {
        $action_info = $server_config->{action}{ lc $action_redir };
        unless ( $action_info ) {
            $log_act->warn( "Failed redirect from '$current_name' to ",
                            "'$action_redir': no action defined " );
            return undef;
        }
        $log_act->is_debug &&
            $log_act->debug( "Redirect to '$action_redir'" );
        $current_name = $action_redir;
    }
    return $action_info;
}


sub lookup_action {
    my ( $self, $action_name, $props ) = @_;
    $log_act ||= get_logger( LOG_ACTION );
    my $action_info = $self->lookup_action_info( $action_name );
    unless ( $action_info ) {
        my $msg = "No action found for '$action_name'";
        $log_act->error( $msg );
        OpenInteract2::Exception->throw( $msg );
    }
    return OpenInteract2::Action->new( $action_info, $props );
}

sub lookup_action_none {
    my ( $self ) = @_;
    my $action_name = $self->server_config->{action_info}{none};
    return $self->_create_action_from_name(
        $action_name, 'action_info.none'
    );
}

sub lookup_action_not_found {
    my ( $self ) = @_;
    my $action_name = $self->server_config->{action_info}{not_found};
    return $self->_create_action_from_name(
        $action_name, 'action_info.not_found'
    );
}

sub _create_action_from_name {
    my ( $self, $name, $key ) = @_;
    unless ( $name ) {
        my $msg = join( '',
            "Check your server configuration -- you must define an ",
            "action number in your server configuration under '$key'"
        );
        $log_act ||= get_logger( LOG_ACTION );
        $log_act->error( $msg );
        OpenInteract2::Exception->throw( $msg );
    }
    return $self->lookup_action( $name );
}

sub lookup_default_action_info {
    my ( $self ) = @_;
    return $self->server_config->{action_info}{default};
}


########################################
# OBJECT CLASS LOOKUP

sub lookup_object {
    my ( $self, $object_name ) = @_;
    $log_spops ||= get_logger( LOG_SPOPS );
    unless ( $object_name ) {
        my $msg = "Cannot lookup object class without object name";
        $log_spops->error( $msg );
        OpenInteract2::Exception->throw( $msg );
    }
    my $spops_config = $self->spops_config;
    unless ( $spops_config->{ lc $object_name } ) {
        my $msg = "No object class found for '$object_name'";
        $log_spops->error( $msg );
        OpenInteract2::Exception->throw( $msg );
    }
    my $use_name = lc $object_name;

    # 'alias_class' is defined in the common case when we want to
    # generate the persistence class ('class') and then subclass it
    # for our customizations ('alias_class')

    my $object_class = $spops_config->{ $use_name }{alias_class}
                       || $spops_config->{ $use_name }{class};
    $log_spops->is_debug &&
        $log_spops->debug( "Found class '$object_class' for '$object_name'" );
    return $object_class;
}


########################################
# CONTROLLER LOOKUP

sub lookup_controller_config {
    my ( $self, $name ) = @_;
    if ( $name ) {
        return $self->server_config->{controller}{ $name };
    }
    return $self->server_config->{controller};
}


########################################
# FULLTEXT INDEXING LOOKUP

sub lookup_fulltext_config {
    my ( $self, $name ) = @_;
    if ( $name ) {
        return $self->server_config->{fulltext}{ $name };
    }
    return $self->server_config->{fulltext};
}

sub fulltext_indexer {
    my ( $self, $indexer_name ) = @_;
    $log_act ||= get_logger( LOG_ACTION );

    my $all_config = $self->lookup_fulltext_config;
    unless ( $indexer_name ) {
        $indexer_name = $all_config->{default};
        unless ( $indexer_name ) {
            OpenInteract2::Exception->throw(
                "No fulltext indexer defined in server configuration ",
                "key 'fulltext.default'" );
        }
    }

    $log_act->is_debug &&
        $log_act->debug( "Fulltext indexer configured: $indexer_name" );
    my $ft_config = $all_config->{ $indexer_name };
    unless ( ref $ft_config eq 'HASH' ) {
        OpenInteract2::Exception->throw(
            "Fulltext indexer '$indexer_name' set in server ",
            "configuration key 'fulltext.default' does not ",
            "have corresponding configuration section." );
    }

    my $ft_class = $ft_config->{class};
    return $ft_class->new( $ft_config );
}


########################################
# CONTENT GENERATOR LOOKUP

sub lookup_content_generator_config {
    my ( $self, $name ) = @_;
    if ( $name ) {
        return $self->server_config->{content_generator}{ $name };
    }
    return $self->server_config->{content_generator};
}


########################################
# OBSERVERS

sub lookup_observer {
    my ( $self, $name ) = @_;
    if ( $name ) {
        return $self->{observers}{ $name };
    }
    return $self->{observers};
}

sub set_observer_registry {
    my ( $self, $registry ) = @_;
    $self->{observers} = $registry;
    return;
}

sub add_observer {
    my ( $self, $observer_name, $observer_info ) = @_;
    OpenInteract2::Observer->register_observer(
            $observer_name, $observer_info, $self->{observers} );
}

sub map_observer {
    my ( $self, $observer_name, $action_or_name ) = @_;
    OpenInteract2::Observer->add_observer_to_action( $observer_name, $action_or_name );
}


########################################
# DIRECTORY/FILE LOOKUPS

sub lookup_directory {
    my ( $self, $dir_name ) = @_;
    if ( $dir_name ) {
        return $self->server_config->{dir}{ $dir_name };
    }
    return $self->server_config->{dir};
}

# TODO: What happens if someone specifies a fully-qualified directory?

sub lookup_temp_lib_directory {
    my ( $self ) = @_;
    my $bootstrap = $self->bootstrap;
    my $lib_dir = $bootstrap->temp_lib_dir || DEFAULT_TEMP_LIB_DIR;
    return File::Spec->catdir( $bootstrap->website_dir, $lib_dir );
}

sub lookup_temp_lib_refresh_filename {
    return 'refresh.txt';
}

sub lookup_override_action_filename {
    return 'action_override.ini';
}

sub lookup_override_spops_filename {
    return 'spops_override.ini';
}


########################################
# LOOKUPS, OTHER

sub lookup_session_config {
    my ( $self ) = @_;
    return $self->server_config->{session_info};
}

sub lookup_login_config {
    my ( $self ) = @_;
    return $self->server_config->{login};
}

sub lookup_mail_config {
    my ( $self ) = @_;
    return $self->server_config->{mail};
}

sub lookup_language_config {
    my ( $self ) = @_;
    return $self->server_config->{language};
}

sub lookup_cache_config {
    my ( $self ) = @_;
    return $self->server_config->{cache};
}

sub lookup_config_watcher_config {
    my ( $self ) = @_;
    return $self->server_config->{config_watcher};
}

sub lookup_redirect_config {
    my ( $self ) = @_;
    return $self->server_config->{redirect};
}

sub lookup_box_config {
    my ( $self ) = @_;
    return $self->server_config->{box};
}


########################################
# CLASS LOOKUP


sub lookup_class {
    my ( $self, $name ) = @_;
    if ( $name ) {
        return $self->server_config->{system_class}{ $name };
    }
    return $self->server_config->{system_class};
}


# Config shortcut

# NOTE: Coupling to OI2::URL->create_from_action with the
# 'url_primary' key.

sub action_table {
    my ( $self, $table ) = @_;
    $log_act ||= get_logger( LOG_ACTION );
    if ( $table ) {
        $log_act->is_info &&
            $log_act->info( "Assigning new action table" );
        $self->server_config->{action} = $table;
        my %url_to_name = ();
        while ( my ( $name, $info ) = each %{ $table } ) {
            next if ( $info->{redir} );
            $log_act->is_debug &&
                $log_act->debug( "Finding URL(s) for action '$name'" );
            my $action = eval { OpenInteract2::Action->new( $info ) };
            if ( $@ ) {
                $log_act->error(
                    "Failed to create action '$name' when assigned a new ",
                    "set of action configurations. Will remove action data ",
                    "from action table. Error: $@" );
                delete $self->server_config->{action}->{ $name };
            }
            else {
                my $respond_urls = $action->get_dispatch_urls;
                $url_to_name{ $_ } = $name for ( @{ $respond_urls } );
                $info->{url_primary} = $respond_urls->[0];
            }
        }
        $self->server_config->{action_url} = \%url_to_name;
    }
    return $self->server_config->{action};
}


# Config shortcut

sub spops_config {
    my ( $self, $table ) = @_;
    $log_spops ||= get_logger( LOG_SPOPS );
    if ( $table ) {
        $log_spops->is_info &&
            $log_spops->info( "Assigning new SPOPS configuration" );
        $self->server_config->{SPOPS} = $table;
    }
    return $self->server_config->{SPOPS};
}

# Config shortcut

sub assign_datasource_config {
    my ( $self, $name, $config ) = @_;
    unless ( $name and $config ) {
        return;
    }
    $self->server_config->{datasource}{ $name } = $config;
    return $config;
}

sub lookup_datasource_config {
    my ( $self, $name ) = @_;
    if ( $name ) {
        return $self->server_config->{datasource}{ $name };
    }
    return $self->server_config->{datasource};
}

sub lookup_datasource_type_config {
    my ( $self, $type ) = @_;
    if ( $type ) {
        return $self->server_config->{datasource_type}{ $type };
    }
    return $self->server_config->{datasource_type};
}

sub lookup_system_datasource_name {
    my ( $self ) = @_;
    return $self->server_config->{datasource_config}{system};
}

sub lookup_default_datasource_name {
    my ( $self ) = @_;
    return $self->server_config->{datasource_config}{spops};
}

sub lookup_default_ldap_datasource_name {
    my ( $self ) = @_;
    return $self->server_config->{datasource_config}{ldap};
}

sub lookup_default_object_id {
    my ( $self, $name ) = @_;
    if ( $name ) {
        return $self->server_config->{default_objects}{ $name };
    }
    return $self->server_config->{default_objects};
}

sub lookup_id_config {
    my ( $self, $definition ) = @_;
    if ( $definition ) {
        return $self->{server_config}{id}{ $definition };
    }
    return $self->{server_config}{id};
}


########################################
# GLOBAL RESOURCES

# Get the named datasource -- just pass along the request to the
# DatasourceManager

sub datasource {
    my ( $self, $name ) = @_;

    # TODO: Why choose the 'system' default here?
    $name ||= $self->server_config->{datasource_config}{system};
    return OpenInteract2::DatasourceManager->datasource( $name );
}

sub content_generator {
    my ( $self, $name ) = @_;
    return OpenInteract2::ContentGenerator->instance( $name );
}


sub assign_default_language_handle {
    my ( $self, $lh ) = @_;
    $DEFAULT_LANGUAGE_HANDLE = $lh
}

sub language_handle {
    my ( $self, $lang ) = @_;
    if ( $self->request and my $h = $self->request->language_handle ) {
        return $h;
    }
    elsif ( $lang ) {
        return OpenInteract2::I18N->get_handle( $lang );
    }
    else {
        return $DEFAULT_LANGUAGE_HANDLE;
    }
}

sub cleanup_request {
    my ( $self ) = @_;
    $self->set( $_, undef )  for ( @REQUEST_FIELDS );

    # TODO: These two methods Needed?
    $self->clear_global_attributes;
    $self->clear_exceptions;
}


# Shortcut -- use to check security on classes that are not derived
# from SPOPS::Secure, or from other resources

sub check_security {
    my ( $self, $params ) = @_;
    my $log_sec = get_logger( LOG_SECURITY );

    # TODO: make static at startup...
    my $security_class = $self->lookup_object( 'security' );

    my %security_info = ( security_object_class => $security_class,
                          class                 => $params->{class},
                          object_id             => $params->{object_id},
                          user                  => $params->{user},
                          group                 => $params->{group} );
    my $request = $self->request;
    if ( $request and $request->auth_is_logged_in ) {
        $log_sec->is_debug &&
            $log_sec->debug( "Assigning user/group from login" );
        $security_info{user}  ||= $request->auth_user;
        $security_info{group} ||= $request->auth_group;
    }
    $log_sec->is_debug &&
        $log_sec->debug( "Checking security for '$params->{class}' ",
                         "'$params->{object_id}' with '$security_class'" );
    return SPOPS::Secure->check_security( \%security_info );
}


########################################
# EXCEPTIONS

# Exception shortcuts
# TODO: remove?

sub throw            { shift; goto &OpenInteract2::Exception::throw( @_ ) }


# outside world doesn't need to know...

sub dump {
    shift;
    my $output = '';
    $output .= Dumper( $_ ) for ( @_ );
    return $output;
}

1;

__END__