view release on metacpan or  search on metacpan

lib/App/Context.pm  view on Meta::CPAN

    if ($App::DEBUG >= 2) {
        my (@str, $key);
        push(@str,"Context->new(): conf=$conf_class\n");
        foreach $key (sort keys %options) {
            push(@str, "   $key => $options{$key}\n");
        }
        $self->dbgprint(join("",@str));
    }

    ##############################################################
    # initialize conf
    ##############################################################
    my $conf = {};

    eval {

        # Initialize from "app.pl" or other file/source specified by the class
        $conf = App->new($conf_class, "new", \%options);

        # Override any values which are supplied in "app.conf" (the "deployment descriptor")
        foreach my $var (keys %options) {
            if ($var =~ /^app\.(.+)/) {
                $conf->set($1, $options{$var});
            }
        }
    };
    $self->add_message($@) if ($@);

    $self->{conf} = $conf;

    ##############################################################
    # Include and Overlay $conf with additional files
    ##############################################################
    my ($includes);
    $includes = $conf->{global}{include} if ($conf->{global});
    if ($includes && ref($includes) eq "ARRAY") {
        my $options = $self->{options};
        my $prefix  = $options->{prefix};
        my (@include_files, $cond, $include_files, $matches);
        for (my $i = 0; $i <= $#$includes; $i += 2) {
            $cond = $includes->[$i];
            $include_files = $includes->[$i+1];
            $matches = $self->cond_matches_options($cond, $options);
            if ($matches) {
                if (ref($include_files) eq "ARRAY") {
                    @include_files = @$include_files;
                }
                elsif (ref($include_files) eq "") {
                    @include_files = ( $include_files );
                }
                foreach my $conf_file (@include_files) {
                    $conf_file = "$prefix/etc/app/$conf_file" if ($conf_file !~ m!^/!);
                    if ($self->{conf_included}{$conf_file}) {
                        print STDERR "Conf global include: [$cond][$conf_file] already included\n" if ($options{debug_conf});
                        next;
                    }
                    if (-r $conf_file) {
                        $options{conf_file} = $conf_file;
                        my $aux_conf = $conf_class->create({ %options });
                        $conf->overlay($aux_conf);
                        print STDERR "Conf global include: [$cond][$conf_file] included (overlayed)\n" if ($options{debug_conf});
                    }
                    else {
                        print STDERR "Conf global include: [$cond][$conf_file] not readable\n" if ($options{debug_conf});
                    }
                    $self->{conf_included}{$conf_file} = 1;
                }
            }
            print STDERR "Conf global include: [$cond] did not match options\n" if (!$matches && $options{debug_conf});
        }
    }

    ##############################################################
    # misc
    ##############################################################
    if (defined $options{debug_conf} && $options{debug_conf} >= 2) {
        $self->dbgprint($self->{conf}->dump());
    }

    $self->{events} = [];      # the event queue starts empty
    $self->{returntype} = "default";  # assume default return type

    $self->{scheduled_events} = [];
    $self->{scheduled_event} = {};

    $self->{event_loop_extensions} = [];

    $self->_init(\%options);   # allows the subclass to do initialization

    $self->set_current_session("default");

    if ($options{authentication_class}) {
        $self->authentication("default", class => $options{authentication_class});
    }

    &App::sub_exit($self) if ($App::trace);
    return $self;
}

sub _default_session_class {
    &App::sub_entry if ($App::trace);
    &App::sub_exit("App::Session") if ($App::trace);
    return("App::Session");
}

# NOTE: This is very similar logic to some logic in App::Options to see if sections
#       of app.conf are active.
sub cond_matches_options {
    &App::sub_entry if ($App::trace);
    my ($self, $cond_str, $options) = @_;
    my ($var, $value, $regexp, $cond, $cond_value);
    my $matches = 1;                      # assume the condition matches
    my @cond = split(/;/,$cond_str);      # separate the conditions that must be satisfied
    foreach $cond (@cond) {  # check each condition
        if ($cond =~ /^([^=]+)=(.*)$/) {  # i.e. city=ATL or name=/[Ss]tephen/
            $var = $1;
            $cond_value = $2;
        }
        else {              # i.e. [go] matches the program (app) named "go"
            $var = "app";
            $cond_value = $cond;

lib/App/Context.pm  view on Meta::CPAN

  2. optional conf of the service's service_type (in Conf)
     i.e. $conf->{RepositoryType}{$repository_type}

  3. named parameters to the service() call

All service configuration happens before instantiation
this allows you to override the "service_class" in the configuration
in time for instantiation

=cut

sub service {
    &App::sub_entry if ($App::trace);
    my ($self, $type, $name, %named) = @_;
    $self->dbgprint("Context->service(" . join(", ",@_) . ")")
        if ($App::DEBUG && $self->dbg(3));
    my $options = $self->{options};

    my ($args, $new_service, $override, $lightweight, $attrib);
    my ($service, $conf, $class, $session);
    my ($service_store, $service_conf, $service_type, $service_type_conf);
    my ($default);

    # $type (i.e. SessionObject, Session, etc.) must be supplied
    if (!defined $type) {
        App::Exception->throw(
            error => "cannot create a service of unknown type\n",
        );
    }

    if (%named) {
        $args = \%named;
    }
    else {
        $args = {};
    }

    if (! defined $name || $name eq "") {    # we need a name!
        $name = "default";
    }

    $session = $self->{session};
    $service = $session->{cache}{$type}{$name};  # check the cache
    $conf = $self->{conf};
    $service_conf = $conf->{$type}{$name};
    my $temporary = ($name eq "temporary") || $args->{temporary};
    my $service_initialized = ($service && ref($service) ne "HASH");
    #print "$type($name): SERVICE=$service INIT=$service_initialized\n";

    ##############################################################
    # Load extra conf on demand
    ##############################################################
    if (!$service_initialized && !$service_conf && $name !~ /-/) {   # if it's not a contained widget, try the file system
        my $prefix = $options->{prefix};
        my $conf_type = $options->{conf_type} || "pl";
        my $conf_file = "$prefix/etc/app/$type.$name.$conf_type";
        if (!$self->{conf_included}{$conf_file} && -r $conf_file) {
            $options->{conf_file} = $conf_file;
            my $aux_conf = App::Conf::File->create({ %$options });
            $conf->overlay($aux_conf);
            $service_conf = $conf->{$type}{$name};
        }
        $self->{conf_included}{$conf_file} = 1;
    }

    ##############################################################
    # conf includes
    ##############################################################
    if (!$service_initialized && $service_conf && $service_conf->{include}) {
        my $prefix = $options->{prefix};
        my (@include_files);
        my $include_files = $service_conf->{include};
        if (ref($include_files) eq "ARRAY") {
            @include_files = @$include_files;
        }
        elsif (ref($include_files) eq "") {
            @include_files = ( $include_files );
        }
        foreach my $conf_file (@include_files) {
            $conf_file = "$prefix/etc/app/$conf_file" if ($conf_file !~ m!^/!);
            next if ($self->{conf_included}{$conf_file});
            if (-r $conf_file) {
                $options->{conf_file} = $conf_file;
                my $aux_conf = App::Conf::File->create({ %$options });
                $conf->overlay($aux_conf);
            }
            $self->{conf_included}{$conf_file} = 1;
        }
    }

    ##############################################################
    # Detect Deprecated Services
    ##############################################################
    if (!$service_initialized && $service_conf) {
        if ($service_conf->{deprecated}) {
            my $message_suffix = $service_conf->{deprecated};
            my $message = "WARNING: $type($name) deprecated";
            $message .= ": $message_suffix" if ($message_suffix ne "1");
            my $deprecated_action = $options->{"app.Context.deprecated_action"};
            if (!$deprecated_action || $deprecated_action eq "none") {
                # do nothing
            }
            elsif ($deprecated_action eq "die") {
                confess $message;
            }
            else {
                $self->log(shortmess($message));
            }
        }
    }

    ##############################################################
    # aliases
    ##############################################################
    if (!$service_initialized && $service_conf) {
        my $alias = $service_conf->{alias};
        if ($alias && $alias ne $name) {
            $service = $session->{cache}{$type}{$alias};
	    $service = $self->service($type, $alias) if (!$service);
            $service_conf = $conf->{$type}{$alias};
            $name = $alias;
        }
        elsif ($type ne "Authorization" && ($service_conf->{clone} || $service_conf->{auth_clone})) {
            my $clone = $self->get_auth_attrib_value($service_conf, $type, $name, "clone");
            if ($clone) {
                $service_conf = $conf->{$type}{$clone};
            }
        }
    }

    $new_service = 0;

    #   NEVER DEFINED     OR   NON-BLESSED HASH (fully defined services are blessed into classes)
    if ($temporary || !defined $service || ref($service) eq "HASH") {
        $service = {} if (!defined $service);  # start with new hash ref
        $service->{name} = $name;
        $service->{context} = $self;

        $service_store = $session->{store}{$type}{$name};
        if ($temporary) {
            $service_store = undef;
            $service->{temporary} = 1;
        }

        if ($App::DEBUG && $self->dbg(6)) {
            $self->dbgprint("Context->service(): new service. conf=$conf svc=$service sconf=$service_conf sstore=$service_store");
            $self->dbgprint("Context->service():              sconf={",join(",",%$service_conf),"}") if ($service_conf);
            $self->dbgprint("Context->service():              sstore={",join(",",%$service_store),"}") if ($service_store);
        }
    
        $new_service = 1;

        ################################################################
        # start with runtime store for the service from the session
        ################################################################
        if ($service_store) {
            foreach $attrib (keys %$service_store) {
                if (!defined $service->{$attrib}) {
                    $service->{$attrib} = $service_store->{$attrib};
                }
            }
        }

        ################################################################
        # overlay with attributes from the conf file
        ################################################################
        if ($service_conf) {
            foreach $attrib (keys %$service_conf) {
                # include conf attributes only if not set already
                if (!defined $service->{$attrib}) {
                    $service->{$attrib} = $service_conf->{$attrib};
                }
            }
        }

        ################################################################
        # overlay with attributes from the "service_type"
        ################################################################
        $service_type = $service->{type}; # i.e. "session_object_type"
        if ($service_type) {
            $service_type_conf = $conf->{"${type}Type"}{$service_type};
            if ($service_type_conf) {
                foreach $attrib (keys %$service_type_conf) {
                    # include service_type confs only if not set already
                    if (!defined $service->{$attrib}) {
                        $service->{$attrib} = $service_type_conf->{$attrib};
                    }
                }
            }
        }
    }

    ################################################################
    # take care of all %$args attributes next
    ################################################################

    # A "lightweight" service is one which never stores its attributes in
    # the session store.  It assumes that all necessary attributes will
    # be supplied by the conf or by the code.  As a result, a "lightweight"
    # service can usually never handle events.
    #   1. its attributes are only ever required when they are all supplied
    #   2. its attributes will be OK by combining the %$args with the %$conf
    # This all saves space in the Session store, as the attribute values can
    # be relied upon to be supplied by the conf file and the code (and
    # minimal reliance on the Session store).
    # This is really handy when you have something like a huge spreadsheet
    # of text entry cells (usually an indexed variable).

    if ($temporary) {                            # may be specified implicitly
        $lightweight = 1;
    }
    elsif (defined $args->{lightweight}) {       # may be specified explicitly
        $lightweight = $args->{lightweight};
    }
    else {
        $lightweight = ($name =~ /[\{\}\[\]]/);  # or implicitly for indexed variables
    }
    $override = $args->{override};

    if ($new_service || $override) {
        foreach $attrib (keys %$args) {
            # don't include the entry which says whether we are overriding or not
            next if ($attrib eq "override");

            # include attrib if overriding OR attrib not provided in the session_object confs already
            if (!defined $service->{$attrib} ||
                ($override && $service->{$attrib} ne $args->{$attrib})) {
                $service->{$attrib} = $args->{$attrib};
                $session->{store}{$type}{$name}{$attrib} = $args->{$attrib} if (!$lightweight);
            }
            $self->dbgprint("Context->service() [arg=$attrib] name=$name lw=$lightweight ovr=$override",
                " service=", $service->{$attrib},
                " service_store=", $service_store->{$attrib},
                " args=", $args->{$attrib})
                if ($App::DEBUG && $self->dbg(6));
        }
    }