=head1 DESCRIPTION
-Rollen-Modul zur Definition allgemeiner Eigenschaften einer Anwendung
+Basismodul fuer alle Anwendungen, die auf Moose beruhen.
=cut
#---------------------------------------------------------------------------
-use Moose::Role;
+use Moose;
+
+use utf8;
+
+use MooseX::StrictConstructor;
use MooseX::Getopt::Meta::Attribute;
use MooseX::Getopt::Meta::Attribute::NoGetopt;
use Encode qw( decode_utf8 encode_utf8 );
use Data::Dump;
-use utf8;
-
use Carp ();
-with 'FrBr::Common::MooseX::Types';
-with 'FrBr::Common::MooseX::CommonOpts';
-
-sub OK () { 0 }
-sub ERROR () { 1 }
-sub FATAL () { 2 }
+with 'FrBr::Common::MooseX::Role::CommonOpts';
-#-------------------------
-
-
-#---------------------------------------------------------------------------
+#-----------------------------------------
# Versionitis
ENDE
$Revis =~ s/^.*:\s*(\S+)\s*\$.*/$1/s;
-use version; our $VERSION = qv("0.1"); $VERSION .= " r" . $Revis;
+use version; our $VERSION = qv("0.1.0"); $VERSION .= " r" . $Revis;
############################################################################
=head1 ATTRIBUTES
-Alle durch diese Rolle definierten Attribute
+Alle für dieses allgemeine Anwendungsobjekt definierten Attribute/Eigenschaften,
+die nicht durch dazugehörige Rollen definiert werden.
=cut
return $basename;
}
+#---------------------------------------------------------------------------
+
+=head2 production_state
+
+Produktionsstatus der Anwendung (Produktion, Test oder Entwicklung).
+
+Darf nur den Zustand 'prod', 'test' oder 'dev' annehmen.
+
+=cut
+
+subtype 'ProductionState'
+ => as 'Str'
+ => where { $_ =~ /^prod|test|dev$/ }
+ => message { "Der Status '$_' ist nicht 'prod', 'test' oder 'dev'." };
+
+has 'production_state' => (
+ is => 'rw',
+ isa => 'ProductionState',
+ traits => [ 'Getopt' ],
+ lazy => 1,
+ required => 1,
+ builder => '_build_production_state',
+ documentation => "Produktionsstatus der Anwendung, darf nur den Zustand 'prod', 'test' oder 'dev' annehmen.",
+ cmd_flag => 'production-state',
+ cmd_aliases => [ 'pstate' ],
+);
+
+#------
+
+sub _build_production_state {
+ return 'prod';
+}
+
#-------------------------
=head2 basedir
#-----------------------------------------
+=head2 log4perl_cfg_file
+
+Dateiname der Konfiguration für Log::Log4perl, relativ zum Anwendungs- bzw. zum Konfigurationsverzeichnis.
+
+=cut
+
+has 'log4perl_cfg_file' => (
+ is => 'ro',
+ isa => 'Str',
+ traits => [ 'Getopt' ],
+ lazy => 1,
+ builder => '_build_log4perl_cfg_file',
+ documentation => "Dateiname der Konfiguration für Log::Log4perl, relativ zum Anwendungs- bzw. zum Konfigurationsverzeichnis.",
+ cmd_flag => 'log4perl-cfg-file',
+ cmd_aliases => [ 'log4perl-cfg', 'log4perl' ],
+);
+
+#------
+
+sub _build_log4perl_cfg_file {
+ return 'log4perl.conf';
+}
+
+#-----------------------------------------
+
=head2 watch_delay_log_conf
Alle wieviel Sekunden soll nach Änderung der Konfigurationsdatei für Log4perl gesehen werden
return $_[0]->logger;
}
-#---------------------------------------------------------------------------
+#############################################################################################
# Ändern der Eigenschaften einiger geerbter Attribute
-#---------------------------------------------------------------------------
+
+sub _build_version {
+ return $VERSION;
+}
+
+#############################################################################################
=head1 METHODS
-Methoden dieser Rolle sowie Methodenmodifizierer
+Methoden und Methoden-Modifizierer
-=cut
+=head2 OK()
-around BUILDARGS => sub {
+Gibt immer 0 zurück
- my $orig = shift;
- my $class = shift;
+=head2 ERROR()
- my %Args = @_;
+Gibt immer 1 zurück
- #warn "Bin in '" . __PACKAGE__ . "'\n";
+=head2 FATAL
- return $class->$orig(%Args);
+Gibt immer 2 zurück
-};
+=cut
+
+sub OK { 0 }
+sub ERROR { 1 }
+sub FATAL { 2 }
#---------------------------------------------------------------------------
my $self = shift;
$self->_init_log();
+ $self->exit_code( OK() );
+
};
#---------------------------------
+=head2 BUILD()
+
+Konstruktor
+
+=cut
+
+sub BUILD {
+
+ my $self = shift;
+
+# # Darstellen der Objektstruktur
+# if ( $self->verbose >= 2 ) {
+# # Aufwecken der faulen Hunde
+# my $tmp;
+# $tmp = $self->progname;
+# $tmp = $self->basedir;
+# $self->debug( "Anwendungsobjekt vor der Db-Schema-Initialisierung: ", $self );
+# }
+
+ $self->debug( "Bereit zum Kampf - äh - was auch immer." );
+
+}
+
+#---------------------------------
+
sub _init_log {
my $self = shift;
# Initialisierung Log::Log4Perl ...
+ my $log4perl_cfg_file = $self->log4perl_cfg_file;
+ my $log4perl_local_cfg = $log4perl_cfg_file;
my $log4perl_cfg;
- if ( $self->does( 'FrBr::Common::MooseX::Config' ) ) {
- $log4perl_cfg = file( $self->cfg_dir, 'log4perl_local.conf' );
+
+ # Name von $log4perl_local_cfg ausgehend von $log4perl_cfg generieren
+ {
+ my ( $base, $ext );
+ if ( ( $base, $ext ) = $log4perl_local_cfg =~ /^(.*)\.([^\.]+)$/s ) {
+ $log4perl_local_cfg = $base . "_local." . $ext;
+ }
+ else {
+ $log4perl_local_cfg .= "_local";
+ }
+ }
+
+ if ( $self->does( 'FrBr::Common::MooseX::Role::Config' ) ) {
+ $log4perl_cfg = file( $self->cfg_dir, $log4perl_local_cfg );
}
else {
- $log4perl_cfg = file( $self->basedir, 'log4perl_local.conf' );
+ $log4perl_cfg = file( $self->basedir, $log4perl_local_cfg );
}
+
+ # Suche nach der Log-Config-Datei ...
warn sprintf( "Suche nach Log-Config-Datei %s ...\n", $log4perl_cfg ) if $self->verbose >= 2;
unless ( -f $log4perl_cfg->stringify ) {
- if ( $self->does( 'FrBr::Common::MooseX::Config' ) ) {
- $log4perl_cfg = file( $self->cfg_dir, 'log4perl.conf' );
+ # Nach der normalen Variante von log4perl.conf gucken ...
+ if ( $self->does( 'FrBr::Common::MooseX::Role::Config' ) ) {
+ $log4perl_cfg = file( $self->cfg_dir, $log4perl_cfg_file );
}
else {
- $log4perl_cfg = file( $self->basedir, 'log4perl.conf' );
+ $log4perl_cfg = file( $self->basedir, $log4perl_cfg_file );
}
warn sprintf( "Suche nach Log-Config-Datei %s ...\n", $log4perl_cfg ) if $self->verbose >= 2;
undef $log4perl_cfg unless -f $log4perl_cfg->stringify;
}
+
if ( $log4perl_cfg ) {
+ # Log-Config-Datei gefunden
my $delay = $self->watch_delay_log_conf;
if ($delay) {
Log::Log4perl::init_and_watch( $log4perl_cfg->stringify, $delay );
} else {
Log::Log4perl::init( $log4perl_cfg->stringify );
}
- $self->debug( "Verwende $log4perl_cfg als Konfigurationsdatei für Log::Log4Perl." );
+ $self->debug( sprintf( "Verwende '%s' als Konfigurationsdatei für Log::Log4Perl.", $log4perl_cfg ) );
}
else {
+ # oder auch nicht
my $app = $self->progname;
my $conf_hash = {
'log4perl.rootLogger' => ( $self->verbose ? 'DEBUG' : 'INFO' ) . ', ScreenApp',
$self->debug( "Standardkonfiguration für Log::Log4Perl initialisiert." );
}
- $SIG{__WARN__} = sub { $self->_log( __PACKAGE__, 'warn', 2, \@_ ); };
+# $SIG{__WARN__} = sub { $self->_log( __PACKAGE__, 'warn', 2, \@_ ); };
+
+}
+
+#---------------------------------
+
+=head2 _log( $package, $type, $depth, $message )
+
+Lokale Funktion, die von den Log::Log4perl-Wrappern aufgerufen wird
+und die Informationen an die entsprechenden Log::Log4perl-Methoden übergibt.
+
+=cut
+
+sub _log {
+
+ my $self = shift;
+
+ local $SIG{CHLD} = 'DEFAULT';
+
+ my ( $package, $type, $depth, $message ) = @_;
+
+ my @Msg = ();
+ for my $m ( @$message ) {
+ push @Msg, encode_utf8($m);
+ }
+
+ local $Log::Log4perl::caller_depth = $depth;
+ $self->log($package)->$type( @Msg );
}
#---------------------------------
-{
+=head2 debug( @message )
+
+Wrapper-Methode für Log::Log4perl::debug()
+
+=cut
+
+sub debug {
+
+ my ( $self, @message ) = @_;
+ my ( $package, $filename, $line ) = caller;
+
+ return if $self->verbose < 1;
+
+ my $msg = [];
+ for my $m ( @message ) {
+ next unless defined $m;
+ if ( ref($m) ) {
+ $m = Data::Dump::dump($m);
+ }
+ push @$msg, $m;
+ }
+
+ my $depth = $Log::Log4perl::caller_depth;
+ $depth = 1 unless $depth > 0;
+ $depth++;
+ $self->_log( $package, 'debug', $depth, $msg );
+
+}
+
+#---------------------------------
+
+=head2 is_debug( )
+
+Wrapper-Methode für Log::Log4perl::is_debug()
+
+=cut
+
+#---------------------------------
+
+sub is_debug {
+
+ my ( $self, @message ) = @_;
+ my ( $package, $filename, $line ) = caller;
+
+ my $logger = $self->logger($package);
+ return $logger->is_debug;
+
+}
+
+#---------------------------------
+
+#sub Moose::Meta::Attribute::new {
+# my ($class, $name, %options) = @_;
+# $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
+#
+# delete $options{__hack_no_process_options};
+#
+# return $class->SUPER::new($name, %options);
+#}
+
+###################################################################################
+
+# Code, der beim Laden dieses Moduls ausgeführt wird:
+
+=head2 info( @message )
+
+Wrapper-Methode für Log::Log4perl::info()
+
+=head2 is_info( )
+
+Wrapper-Methode für Log::Log4perl::is_info()
- my @levels = ( 'debug', 'info', 'warn', 'error', 'fatal' );
+=head2 warn( @message )
+
+Wrapper-Methode für Log::Log4perl::warn()
+
+=head2 is_warn( )
+
+Wrapper-Methode für Log::Log4perl::is_warn()
+
+=head2 error( @message )
+
+Wrapper-Methode für Log::Log4perl::error()
+
+=head2 is_error( )
+
+Wrapper-Methode für Log::Log4perl::is_error()
+
+=head2 fatal( @message )
+
+Wrapper-Methode für Log::Log4perl::fatal()
+
+=head2 is_fatal( )
+
+Wrapper-Methode für Log::Log4perl::is_fatal()
+
+=cut
+
+#---------------------------------
+
+{
+
+ my @levels = ( 'info', 'warn', 'error', 'fatal' );
for my $level ( @levels ) {
};
- }
-
-}
-
-#---------------------------------
+ *{"is_$level"} = sub {
-sub _log {
+ my ( $self, @message ) = @_;
+ my ( $package, $filename, $line ) = caller;
- my $self = shift;
+ my $logger = $self->logger($package);
+ my $func = "is_" . $level;
+ return $logger->$func;
- local $SIG{CHLD} = 'DEFAULT';
+ };
- my ( $package, $type, $depth, $message ) = @_;
- my @Msg = ();
- for my $m ( @$message ) {
- push @Msg, encode_utf8($m);
}
- local $Log::Log4perl::caller_depth = $depth;
- $self->log($package)->$type( @Msg );
-
}
-#---------------------------------
-
-sub Moose::Meta::Attribute::new {
- my ($class, $name, %options) = @_;
- $class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
-
- delete $options{__hack_no_process_options};
-
- return $class->SUPER::new($name, %options);
-}
-
-
-
#---------------------------------------------------------------------------
no Moose::Role;
+__PACKAGE__->meta->make_immutable;
+
1;
__END__
projects / my-stuff / perl.git / commitdiff