From: Frank Brehm Date: Mon, 10 May 2010 07:46:41 +0000 (+0000) Subject: allg. Anwendungsobjekt erstmal fertig X-Git-Url: https://git.uhu-banane.net/?a=commitdiff_plain;h=bd82fb3e153ecc48e42c5294084ea3029e9ae59b;p=my-stuff%2Fperl.git allg. Anwendungsobjekt erstmal fertig git-svn-id: http://svn.brehm-online.com/svn/my-stuff/Perl@56 ec8d2aa5-1599-4edb-8739-2b3a1bc399aa --- diff --git a/lib/FrBr/Common/MooseX/App.pm b/lib/FrBr/Common/MooseX/App.pm index 4ee02fd..12522b6 100644 --- a/lib/FrBr/Common/MooseX/App.pm +++ b/lib/FrBr/Common/MooseX/App.pm @@ -9,13 +9,17 @@ FrBr::Common::MooseX::App; =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; @@ -28,21 +32,11 @@ use FindBin; 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 @@ -51,13 +45,14 @@ my $Revis = <<'ENDE'; 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 @@ -87,6 +82,39 @@ sub _build_progname { 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 @@ -139,6 +167,31 @@ sub _build_exit_code { #----------------------------------------- +=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 @@ -177,30 +230,38 @@ sub log { 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 } #--------------------------------------------------------------------------- @@ -209,43 +270,90 @@ before BUILD => sub { 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', @@ -260,15 +368,142 @@ sub _init_log { $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 ) { @@ -297,46 +532,27 @@ sub _init_log { }; - } - -} - -#--------------------------------- + *{"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__