view release on metacpan or  search on metacpan

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

        }

        return Prophet::Replica->get_handle(
            url        => $self->local_replica_url,
            app_handle => $self,
        );
    },
);

has config => (
    is      => 'rw',
    isa     => 'Prophet::Config',
    default => sub {
        my $self = shift;
        return Prophet::Config->new(
            app_handle => $self,
            confname   => 'prophetrc',
        );
    },
    documentation => "This is the config instance for the running application",
);

use constant DEFAULT_REPLICA_TYPE => 'prophet';


sub default_replica_type {
    my $self = shift;
    return $ENV{'PROPHET_REPLICA_TYPE'} || DEFAULT_REPLICA_TYPE;
}


sub local_replica_url {
    my $self = shift;
    if (@_) {
        $ENV{'PROPHET_REPO'} = shift;
    }

    return $ENV{'PROPHET_REPO'} || undef;
}

sub require {
    my $self  = shift;
    my $class = shift;
    $self->_require( module => $class );
}

sub try_to_require {
    my $self  = shift;
    my $class = shift;
    $self->_require( module => $class, quiet => 1 );
}

sub _require {
    my $self  = shift;
    my %args  = ( module => undef, quiet => undef, @_ );
    my $class = $args{'module'};

    # Quick hack to silence warnings.
    # Maybe some dependencies were lost.
    unless ($class) {
        warn sprintf( "no class was given at %s line %d\n", (caller)[ 1, 2 ] );
        return 0;
    }

    return 1 if $self->already_required($class);

    # .pm might already be there in a weird interaction in Module::Pluggable
    my $file = $class;
    $file .= ".pm"
      unless $file =~ /\.pm$/;

    $file =~ s/::/\//g;

    my $retval = eval {
        local $SIG{__DIE__} = 'DEFAULT';
        CORE::require "$file";
    };

    my $error = $@;
    if ( my $message = $error ) {
        $message =~ s/ at .*?\n$//;
        if ( $args{'quiet'} and $message =~ /^Can't locate \Q$file\E/ ) {
            return 0;
        } elsif ( $error !~ /^Can't locate $file/ ) {
            die $error;
        } else {
            warn sprintf( "$message at %s line %d\n", ( caller(1) )[ 1, 2 ] );
            return 0;
        }
    }

    return 1;
}


sub already_required {
    my ( $self, $class ) = @_;

    return 0 if $class =~ /::$/;    # malformed class

    my $path = join( '/', split( /::/, $class ) ) . ".pm";
    return ( $INC{$path} ? 1 : 0 );
}

sub set_db_defaults {
    my $self     = shift;
    my $settings = $self->database_settings;
    for my $name ( keys %$settings ) {
        my ( $uuid, @metadata ) = @{ $settings->{$name} };

        my $s = $self->setting(
            label   => $name,
            uuid    => $uuid,
            default => \@metadata,
        );

        $s->initialize;
    }
}

sub setting {