From: Frank Brehm Date: Thu, 1 Apr 2010 17:26:26 +0000 (+0000) Subject: Weitergekommen X-Git-Url: https://git.uhu-banane.org/?a=commitdiff_plain;h=49d3281dc3ff57a753652595c9794a99c981a873;p=my-stuff%2Fperl.git Weitergekommen git-svn-id: http://svn.brehm-online.com/svn/my-stuff/Perl@48 ec8d2aa5-1599-4edb-8739-2b3a1bc399aa --- diff --git a/lib/FrBr/Common/MooseX/App.pm b/lib/FrBr/Common/MooseX/App.pm new file mode 100644 index 0000000..be5bc5a --- /dev/null +++ b/lib/FrBr/Common/MooseX/App.pm @@ -0,0 +1,173 @@ +package FrBr::Common::MooseX::App; + +# $Id$ +# $URL$ + +=head1 NAME + +FrBr::Common::MooseX::App; + +=head1 DESCRIPTION + +Rollen-Modul zur Definition allgemeiner Eigenschaften einer Anwendung + +=cut + +#--------------------------------------------------------------------------- + +use Moose::Role; + +use MooseX::Getopt::Meta::Attribute; +use MooseX::Getopt::Meta::Attribute::NoGetopt; +use MooseX::Types::Path::Class; +use Path::Class; +use File::Basename; +use FindBin; +use Encode qw( decode_utf8 encode_utf8 ); + +use utf8; + +use Carp (); + +with 'FrBr::Common::MooseX::Types'; +with 'FrBr::Common::MooseX::CommonOpts'; + +sub OK () { 0 } +sub ERROR () { 1 } +sub FATAL () { 2 } + +#------------------------- + + +#--------------------------------------------------------------------------- + +# Versionitis + +my $Revis = <<'ENDE'; + $Revision$ +ENDE +$Revis =~ s/^.*:\s*(\S+)\s*\$.*/$1/s; + +use version; our $VERSION = qv("0.1"); $VERSION .= " r" . $Revis; + +############################################################################ + +=head1 ATTRIBUTES + +Alle durch diese Rolle definierten Attribute + +=cut + +#--------------------------------------------------------------------------- + +=head2 progname + +Programmname. Wird zum Beispiel für die PID-Datei verwendet. + +=cut + +has progname => ( + isa => 'Str', + is => 'ro', + traits => [ 'Getopt' ], + lazy => 1, + required => 1, + builder => '_build_progname', + documentation => 'Programmname. Wird zum Beispiel für die PID-Datei verwendet.', +); + +#------ + +sub _build_progname { + my $basename = basename($0); + $basename =~ s/\.pl$//i; + return $basename; +} + +#------------------------- + +=head2 basedir + +Stammverzeichnis der Anwendung + +=cut + +has 'basedir' => ( + is => 'ro', + isa => 'Path::Class::Dir', + traits => [ 'Getopt' ], + coerce => 1, + lazy => 1, + required => 1, + builder => '_build_basedir', + documentation => 'Stammverzeichnis der Anwendung', + cmd_aliases => [ 'base' ], +); + +#------ + +sub _build_basedir { + return dir->new( $FindBin::Bin )->parent->absolute; +} + +#------------------------- + +=head2 exit_code + +Stammverzeichnis der Anwendung + +=cut + +has exit_code => ( + is => 'rw', + isa => 'UnsignedInt', + traits => [ 'NoGetopt' ], + lazy => 1, + required => 1, + builder => '_build_exit_code', + documentation => 'Exitcode der Anwendung (gegenüber der Shell)', +); + +#------ + +sub _build_exit_code { + return 0; +} + +#--------------------------------------------------------------------------- + +with 'FrBr::Common::MooseX::Log'; + +#--------------------------------------------------------------------------- + +=head1 METHODS + +Methoden dieser Rolle sowie Methodenmodifizierer + +=cut + +around BUILDARGS => sub { + + my $orig = shift; + my $class = shift; + + my %Args = @_; + + #warn "Bin in '" . __PACKAGE__ . "'\n"; + + # verbose auf verbose_bool setzen +# $Args{'verbose'} = 1 if $Args{'verbose_bool'} and not exists $Args{'verbose'}; +# delete $Args{'verbose_bool'} if exists $Args{'verbose_bool'}; + + return $class->$orig(%Args); + +}; + +#--------------------------------------------------------------------------- + +no Moose::Role; +1; + +__END__ + +# vim: noai: filetype=perl ts=4 sw=4 : expandtab diff --git a/lib/FrBr/Common/MooseX/CommonOpts.pm b/lib/FrBr/Common/MooseX/CommonOpts.pm index 720a338..a7216c7 100644 --- a/lib/FrBr/Common/MooseX/CommonOpts.pm +++ b/lib/FrBr/Common/MooseX/CommonOpts.pm @@ -95,7 +95,7 @@ has 'show_version' => ( lazy => 1, traits => [ 'Getopt' ], builder => '_build_show_version', - documentation => 'BOOL: Anzeige der Verwendung der Anwendung', + documentation => 'BOOL: Anzeige der Anwendungsversion', cmd_flag => 'version', cmd_aliases => [ 'V' ], ); @@ -194,7 +194,7 @@ sub evaluate_common_options { my $self = shift; -# $self->debug( "Werte allgemeine Optionen aus." ); + $self->debug( "Werte allgemeine Optionen aus." ); $self->_do_show_usage() if $self->show_usage; $self->_do_show_version() if $self->show_version; @@ -261,7 +261,7 @@ sub _do_show_usage { } $max_length = length($Attr->{'show'}) if length($Attr->{'show'}) > $max_length; -# $self->debug( "Attribut: ", $Attr ) if $self->verbose >= 3; + $self->debug( "Attribut: ", $Attr ) if $self->verbose >= 3; push @Attribute, $Attr; } diff --git a/lib/FrBr/Common/MooseX/Log.pm b/lib/FrBr/Common/MooseX/Log.pm new file mode 100644 index 0000000..eb9d003 --- /dev/null +++ b/lib/FrBr/Common/MooseX/Log.pm @@ -0,0 +1,232 @@ +package FrBr::Common::MooseX::Log; + +# $Id$ +# $URL$ + +=head1 NAME + +FrBr::Common::MooseX::Log; + +=head1 DESCRIPTION + +Rollen-Modul zum Einbinden von Loggingmöglichkeiten per Log::Log4perl + +=cut + +#--------------------------------------------------------------------------- + +use Moose::Role; + +use MooseX::Getopt::Meta::Attribute; +use MooseX::Getopt::Meta::Attribute::NoGetopt; +use Log::Log4perl; +use MooseX::Types::Path::Class; +use Path::Class; +use File::Basename; +use FindBin; +use Encode qw( decode_utf8 encode_utf8 ); +use Data::Dump; + +use utf8; + +use Carp (); + +with 'MooseX::Log::Log4perl'; +with 'FrBr::Common::MooseX::Types'; + +#--------------------------------------------------------------------------- + +# Versionitis + +my $Revis = <<'ENDE'; + $Revision$ +ENDE +$Revis =~ s/^.*:\s*(\S+)\s*\$.*/$1/s; + +use version; our $VERSION = qv("0.1"); $VERSION .= " r" . $Revis; + +############################################################################ + +=head1 ATTRIBUTES + +Alle durch diese Rolle definierten Attribute + +=cut + +#----------------------------------------- + +=head2 watch_delay_log_conf + +Alle wieviel Sekunden soll nach Änderung der Konfigurationsdatei für Log4perl gesehen werden + +=cut + +has 'watch_delay_log_conf' => ( + is => 'rw', + isa => 'UnsignedInt', + traits => [ 'Getopt' ], + lazy => 1, + builder => '_build_watch_delay_log_conf', + documentation => 'INT: Alle wieviel Sekunden soll nach Änderung der Konfigurationsdatei für Log4perl gesehen werden', + cmd_flag => 'watch-delay-log-conf', + cmd_aliases => 'watch-delay', +); + +#------ + +sub _build_watch_delay_log_conf { + return 60; +} + +#--------------------------------------------------------------------------- + +=head1 METHODS + +Methoden dieser Rolle sowie Methodenmodifizierer + +=cut + +#around BUILDARGS => sub { +# +# my $orig = shift; +# my $class = shift; +# +# my %Args = @_; +# +# #warn "Bin in '" . __PACKAGE__ . "'\n"; +# +# # verbose auf verbose_bool setzen +# $Args{'verbose'} = 1 if $Args{'verbose_bool'} and not exists $Args{'verbose'}; +# delete $Args{'verbose_bool'} if exists $Args{'verbose_bool'}; +# +# return $class->$orig(%Args); +# +#}; + +#--------------------------------------------------------------------------- + +before BUILD => sub { + + my $self = shift; + $self->_init_log(); + +}; + +#--------------------------------- + +sub _init_log { + + my $self = shift; + + # Initialisierung Log::Log4Perl ... + my $log4perl_cfg; + if ( $self->does( 'FrBr::Common::MooseX::Config' ) ) { + $log4perl_cfg = file( $self->cfg_dir, 'log4perl_local.conf' ); + } + else { + $log4perl_cfg = file( $self->basedir, 'log4perl_local.conf' ); + } + 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' ); + } + else { + $log4perl_cfg = file( $self->basedir, 'log4perl.conf' ); + } + 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 ) { + 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." ); + } + else { + my $app = $self->progname; + my $conf_hash = { + 'log4perl.rootLogger' => ( $self->verbose ? 'DEBUG' : 'INFO' ) . ', ScreenApp', + # Normaler Screen-Appender auf StdErr + 'log4perl.appender.ScreenApp' => 'Log::Log4perl::Appender::Screen', + 'log4perl.appender.ScreenApp.stderr' => 1, + #'log4perl.appender.ScreenApp.utf8' => 1, + 'log4perl.appender.ScreenApp.layout' => 'PatternLayout', + 'log4perl.appender.ScreenApp.layout.ConversionPattern' => '[%d] [' . $app . '] [%p] %m%n', + }; + Log::Log4perl->init($conf_hash); + $self->debug( "Standardkonfiguration für Log::Log4Perl initialisiert." ); + } + + $SIG{__WARN__} = sub { $self->_log( __PACKAGE__, 'warn', 2, \@_ ); }; + +} + +#--------------------------------- + +{ + + my @levels = ( 'debug', 'info', 'warn', 'error', 'fatal' ); + + for my $level ( @levels ) { + + no strict 'refs'; + + *{$level} = sub { + + my ( $self, @message ) = @_; + my ( $package, $filename, $line ) = caller; + + return if $level eq 'debug' and $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, $level, $depth, $msg ); + + }; + + } + +} + +#--------------------------------- + +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 ); + +} + +#--------------------------------------------------------------------------- + +no Moose::Role; +1; + +__END__ + +# vim: noai: filetype=perl ts=4 sw=4 : expandtab