Solstice - Solstice is a Web application development framework for Perl. Based on the MVC programming paradigm, it provides a sensible layout for Web applications that helps you write applications faster and with fewer mistakes.

  my $lang_service = $solstice_subclass->getLangService();
  my $button_service = $solstice_subclass->getButtonService();
  my $message_service = $solstice_subclass->getMessageService();
  my $config_service = $solstice_subclass->getConfigService();
  my $preference_service = $solstice_subclass->getPreferenceService();
  $solstice_subclass->log($log_message);

package Solstice;

# $Id: Model.pm 2393 2005-07-18 17:12:40Z pmichaud $

use 5.006_000;
use strict;
use warnings;

use Solstice::Service::Debug;
use Solstice::ConfigService;
use Solstice::ButtonService;
use Solstice::LogService;
use Solstice::MessageService;
use Solstice::LangService;
use Solstice::PreferenceService;
use Solstice::UserService;
use Solstice::IconService;
use Solstice::HelpService;
use Solstice::IncludeService;
use Solstice::OnloadService;
use Solstice::Service::TempFile;
use Solstice::JavaScriptService;
use Solstice::ContentTypeService;
use Solstice::StringLibrary qw(urlclean);

use UNIVERSAL qw(isa);
use Carp;
use File::Path;

use constant TRUE => 1;
use constant FALSE => 0;
our %service_cache;

our ($VERSION) = ('$Revision: 1440 $' =~ /^\$Revision:\s*([\d.]*)/);

sub new {
    my $class = shift;
    my $self = bless {}, ref $class || $class;

    #we must not ask about development mode if we are a config object - deep recursion
    if( 
        ((ref $self) !~ /^Solstice::Configure|Solstice::ConfigService|Solstice::Model::Config::.*$/) && 
        $self->getConfigService()->getDevelopmentMode()
    ){
        $self->{'_caller'} = Carp::shortmess();
    }
    return $self;
}

sub loadModule {
    my $self = shift;
    my $package = shift;

    my $module = ref($package) || $package;

    #   return TRUE unless $module;
    croak("Cannot load empty module, called from " . join(" ", caller)) unless $module;
    unless( $module =~ /\/|\.pm/ ){ #filename
        $module =~ s/::/\//g;
        $module .= '.pm';
    }

    eval {require $module};
    croak("Could not dynamically load requested module: $@") if $@;

    return TRUE;
}

sub log {
    my $self = shift;
    ref($self) =~ m/^(\w+):.*$/;
    return $self->getLogService($1)->log(@_);
}

sub warn {
    my $self = shift;
    my $msg  = shift;
    CORE::warn $msg . Carp::shortmess . "\n";
}

sub debug {
    my ($self, $tag, $mesg) = @_;
    my ($package, $file, $line) = caller();

    return Solstice::Service::Debug->new()->debug($tag, $mesg, $package, $line);
}

sub getBaseURL {
    my $self = shift;

    my $config      = $self->getConfigService();

    my $use_ssl     = $config->getRequireSSL();
    my $host_name   = $config->get('host_name');
    my $server_port = $config->get('port_number');
    my $base_url    = $config->getURL();

    if ($use_ssl && $server_port && (443 == $server_port)) {
        $server_port = '';
    }
    if (!$use_ssl && $server_port && (80 == $server_port)) {
        $server_port = '';
    }

    my $url = $host_name .
        ($server_port ? ':'.$server_port : '') . '/' .
        $base_url .'/';

    $url =~ s/\/+/\//g;

    $url = 'http' .
        ($use_ssl ? 's' : '') .
        '://' . $url;

    return $url;
}

sub getServerURL {
    my $self = shift;

    my $config      = $self->getConfigService();

    my $use_ssl     = $config->getRequireSSL();
    my $host_name   = $config->get('host_name');
    my $server_port = $config->get('port_number');

    if ($use_ssl && $server_port && (443 == $server_port)) {
        $server_port = '';
    }
    if (!$use_ssl && $server_port && (80 == $server_port)) {
        $server_port = '';
    }

    my $url = $host_name .
        ($server_port ? ':'.$server_port : '') . '/';

    $url =~ s/\/+/\//g;

    $url = 'http' .
        ($use_ssl ? 's' : '') .
        '://' . $url;

    return $url;

}

sub getAppBaseURL {
    my $self = shift;
    my $namespace = shift;

    my $config = $self->getConfigService($namespace);

    return $self->makeURL($self->getBaseURL(), $config->getAppURL());
}

sub getAppRestURL {
    my $self = shift;
    my $namespace = shift;

    my $config = $self->getConfigService($namespace);
    my $rest_path = $config->getWebServiceRestRoot();

    if (!$rest_path) {
        return;
    }

    return $self->makeURL($self->getBaseURL(), $rest_path, $config->getAppURL());
}

sub getConfigService {
    my $self = shift;
    my $namespace = shift;
    my $namespace_key = (defined $namespace) ? $namespace : 'solstice';

    unless (defined $service_cache{'configure'}->{$namespace_key}) {
        $service_cache{'configure'}->{$namespace_key} = Solstice::ConfigService->new($namespace);
    }
    return $service_cache{'configure'}->{$namespace_key};
}

sub getTempFileService {
    my $self = shift;
    my $namespace = shift;

    unless (defined $namespace){
        caller =~ m/^(\w+):.*$/;
        $namespace = $1;
    }

    unless(defined $service_cache{'temp_files'}->{$namespace}){
        $service_cache{'temp_files'}->{$namespace} = Solstice::Service::TempFile->new($namespace);
    }
    $service_cache{'temp_files'}->{$namespace};
}

sub getButtonService {
    my $self = shift;
    my $namespace = shift;

    unless (defined $namespace){
        caller =~ m/^(\w+):.*$/;
        $namespace = $1;
    }
    
    unless (defined $service_cache{'button_service'}->{$namespace}) {
        $service_cache{'button_service'}->{$namespace} = Solstice::ButtonService->new($namespace);
    }
    return $service_cache{'button_service'}->{$namespace};
}

sub getLogService {
    my $self = shift;
    my $namespace = shift;

    unless (defined $namespace) {
        caller =~ m/^(\w+):.*$/;
        $namespace = $1;
    }

    unless (defined $service_cache{'log_service'}->{$namespace}) {
        $service_cache{'log_service'}->{$namespace} = Solstice::LogService->new($namespace);
    }
    return $service_cache{'log_service'}->{$namespace};
}

sub getMessageService {
    my $self = shift;
    
    unless (defined $service_cache{'message_service'}) {
        $service_cache{'message_service'} = Solstice::MessageService->new();
    }
    return $service_cache{'message_service'};
}

sub getJavascriptService {
    my $self = shift;

    unless (defined $service_cache{'javascript_service'}) {
        $service_cache{'javascript_service'} = Solstice::JavaScriptService->new();
    }
    return $service_cache{'javascript_service'};
}

sub getContentTypeService {
    my $self = shift;

    unless (defined $service_cache{'content_type_service'}) {
        $service_cache{'content_type_service'} = Solstice::ContentTypeService->new();
    }
    return $service_cache{'content_type_service'};
}

sub makeURL {
    my $self = shift;
    my @parts = @_;
    my $args;
    $args = pop @parts if ref $parts[$#parts] eq 'HASH';
    my $proto = shift @parts;

    #is it really a separate protocol, or is that included in the first part?
    if($proto =~ /^\w+:\/\/.+/){
        my $first_part;
        ($proto, $first_part) = split(/:\/\//, $proto);
            unshift @parts, $first_part;
    }


    my $url = join('/', @parts);
    $url =~ s/^\/+//;
    $url = urlclean($url);
    $url = "$proto://$url";

    if ($args) {
        $url .= '?';
        for my $key ( keys %$args ) {
            $url .= "$key=" . $args->{$key} . "&";
        }
        $url =~ s/&$/ /;
    }

    return $url;
}

sub getLangService {
    my $self = shift;
    my $namespace = shift;
    
    unless (defined $namespace){
        caller =~ m/^(\w+):.*$/;
        $namespace = $1;
    }

    unless (defined $service_cache{'lang_service'}->{$namespace}) {
        $service_cache{'lang_service'}->{$namespace} = Solstice::LangService->new($namespace);
    }
    return $service_cache{'lang_service'}->{$namespace};
}

sub getPreferenceService {
    my $self = shift;
    my $namespace = shift;

    unless (defined $namespace){
        caller =~ m/^(\w+):.*$/;
        $namespace = $1;
    }

    unless (defined $service_cache{'preference_service'}->{$namespace}) {
        $service_cache{'preference_service'}->{$namespace} = Solstice::PreferenceService->new($namespace);
    }
    return $service_cache{'preference_service'}->{$namespace};    
}

sub getUserService {
    my $self = shift;

    unless (defined $service_cache{'user_service'}) {
        $service_cache{'user_service'} = Solstice::UserService->new();
    }
    return $service_cache{'user_service'};
}

sub getNavigationService {
    my $self = shift;
    
    unless (defined $service_cache{'navigation_service'}) {
        $service_cache{'navigation_service'} = Solstice::NavigationService->new();
    }
    return $service_cache{'navigation_service'};
}

sub getOnloadService {
    my $self = shift;
    
    unless (defined $service_cache{'onload_service'}) {
        $service_cache{'onload_service'} = Solstice::OnloadService->new();
    }
    return $service_cache{'onload_service'};
}

sub getIncludeService {
    my $self = shift;
    return Solstice::IncludeService->new(@_);
}

sub getIconService {
    my $self = shift;
    return Solstice::IconService->new(@_);
}

sub getHelpService {
    my $self = shift;
    return Solstice::HelpService->new(@_);
}

sub isValidInteger {
    my $self = shift;
    my $str  = shift;
    return FALSE unless isValidString(undef, $str, @_);
    return TRUE if (!defined $str);
    return ($str =~ /^[-]?[0-9]+$/) ? TRUE : FALSE;
}

sub isValidPositiveInteger {
    my $self = shift;
    my $str  = shift;
    return FALSE unless isValidString(undef, $str, @_);
    return TRUE if (!defined $str);
    return ($str =~ /^[0-9]+$/ and $str != 0) ? TRUE : FALSE;
}

sub isValidNonNegativeInteger {
    my $self = shift;
    my $str  = shift;
    return FALSE unless isValidString(undef, $str, @_);
    return TRUE if (!defined $str);
    return ($str =~ /^[0-9]+$/) ? TRUE : FALSE;
}

sub isValidNumber {
    my $self = shift;
    my $str  = shift;
    return FALSE unless isValidString(undef, $str, @_);
    return TRUE if (!defined $str);
    return ($str =~ /^[-]?([0-9]*\.[0-9]+|[0-9]+)$/) ? TRUE : FALSE;
}

sub isValidPositiveNumber {
    my $self = shift;
    my $str  = shift;
    return FALSE unless isValidString(undef, $str, @_);
    return TRUE if (!defined $str);
    return ($str =~ /^([0-9]*\.[0-9]+|[0-9]+)$/) ? TRUE : FALSE;
}

sub isValidString {
    my $self = shift;
    my $str = shift;
    return FALSE if (scalar @_);
    return TRUE if (!defined $str);
    return FALSE if (ref $str);
    return FALSE if (ref \$str eq 'GLOB');
    return TRUE;
}

sub isValidEmail {
    my $self = shift;
    my $str  = shift;
    return FALSE unless isValidString(undef, $str, @_);
    return TRUE if (!defined $str);

    #Mail::RFC822::Address was too lax for us and our users, so we 
    #implemented our own sanity test

    return (
        # Dot sanity
        $str !~ /\.{2,}/ && $str !~ /^\./ && 
        
        # Looks like an email?
        lc($str) =~ /^[\w\-\+\.]+\@[a-z0-9\-]*\.[a-z0-9\-\.]+$/
    ) ? TRUE : FALSE;
}

sub isValidURL {
    my $self = shift;
    my $str = shift;
    return FALSE unless isValidString(undef, $str, @_);
    return TRUE if (!defined $str);
    # This should get smarter (or be replaced with a CPAN module).
    # Doesn't currently do any validation after the ://, it just makes 
    # sure there is at least one character, which is obviously not 
    # too satisfactory.
    return FALSE unless $str =~ m'^(http|ftp|https)://[\w]+';
    return TRUE;
}

sub isValidBoolean {
    my $self = shift;
    my $str  = shift;
    return FALSE unless isValidString(undef, $str, @_);
    return TRUE if (!defined $str);
    return ($str =~ /^(0|1)$/) ? TRUE : FALSE;
}

sub isValidObject {
    my $self = shift;
    my ($obj, $class) = @_;
    return TRUE if (! defined $obj);
    return isa($obj, $class) ? TRUE : FALSE;
}

sub isValidDateTime {
    my $self = shift;
    my $obj  = shift;
    return TRUE if (!defined $obj);
    return isa($obj, 'Solstice::DateTime') ? ($obj->isValid() || $obj->isEmpty) : FALSE;
}

sub isValidPerson {
    my $self = shift;
    my $obj  = shift;
    return TRUE if (!defined $obj);
    return isa($obj, 'Solstice::Person') ? TRUE : FALSE;
}

sub isValidGroup {
    my $self = shift;
    my $obj  = shift;
    return TRUE if (!defined $obj);
    return isa($obj, 'Solstice::Group') ? TRUE : FALSE;
}

sub isValidList {
    my $self = shift;
    my $obj  = shift;
    return TRUE if (!defined $obj);
    return isa($obj, 'Solstice::List') ? TRUE : FALSE;
}

sub isValidTree {
    my $self = shift;
    my $obj  = shift;
    return TRUE if (!defined $obj);
    return isa($obj, 'Solstice::Tree') ? TRUE : FALSE;
}

sub isValidArrayRef {
    my $self = shift;
    my $ref  = shift;
    return TRUE if (!defined $ref);
    return UNIVERSAL::isa($ref, 'ARRAY') ? TRUE : FALSE;
}

sub isValidHashRef {
    my $self = shift;
    my $ref  = shift;
    return TRUE if (!defined $ref);
    return (ref($ref) eq 'HASH') ? TRUE : FALSE;
}

# These aliases are just here for historical sake

*isValidFloat = *isValidNumber;
*_isValidInteger = *isValidInteger;
*_isValidPositiveInteger = *isValidPositiveInteger;
*_isValidNonNegativeInteger = *isValidNonNegativeInteger;
*_isValidNumber = *isValidNumber;
*_isValidPositiveNumber = *isValidPositiveNumber;
*_isValidString = *isValidString;
*_isValidEmail = *isValidEmail;
*_isValidURL = *isValidURL;
*_isValidBoolean = *isValidBoolean;
*_isValidObject = *isValidObject;
*_isValidDateTime = *isValidDateTime;
*_isValidPerson = *isValidPerson;
*_isValidGroup = *isValidGroup;
*_isValidList = *isValidList;
*_isValidTree = *isValidTree;
*_isValidArrayRef = *isValidArrayRef;
*_isValidHashRef = *isValidHashRef;

sub _dirCheck {
    my $self = shift;
    my $file_path = shift;

    unless (-d $file_path ){
        mkpath($file_path) or die "Cannot create directory $file_path - called from ". join(' ', caller())."\n";
    }

    unless( -w $file_path ){
        die "Cannot write to directory $file_path - called from ". join(' ', caller()). "\n";

    }
}

#sub DESTROY {
#    my $self = shift;
#    if($self->getConfigService()->getDevelopmentMode() && $self->{"_caller"}){
#        my $orig_error = undef;;
#        if($@){ $orig_error = $@; }
#        eval { die }; 
#        CORE::warn("Leaked ". ref($self) ." freed at process destruction! Created".$self->{'_caller'}) if $@ =~ /global destruction/;
#        $@ = $orig_error;
#    }
#}

1;
__END__