From fd7a9b2351117606b91873a5f533850aa8ecf1f0 Mon Sep 17 00:00:00 2001 From: Frank Brehm Date: Sat, 8 May 2010 17:16:19 +0000 Subject: [PATCH] neue Moose-Rollen dazu git-svn-id: http://svn.brehm-online.com/svn/my-stuff/Perl@54 ec8d2aa5-1599-4edb-8739-2b3a1bc399aa --- lib/FrBr/Common/MooseX/App.pm | 13 + lib/FrBr/Common/MooseX/Role/CommonOpts.pm | 335 ++++++++++++++++ lib/FrBr/Common/MooseX/Role/Config.pm | 440 ++++++++++++++++++++++ lib/FrBr/Common/MooseX/Role/Types.pm | 65 ++++ 4 files changed, 853 insertions(+) create mode 100644 lib/FrBr/Common/MooseX/Role/CommonOpts.pm create mode 100644 lib/FrBr/Common/MooseX/Role/Config.pm create mode 100644 lib/FrBr/Common/MooseX/Role/Types.pm diff --git a/lib/FrBr/Common/MooseX/App.pm b/lib/FrBr/Common/MooseX/App.pm index 2a6c854..4ee02fd 100644 --- a/lib/FrBr/Common/MooseX/App.pm +++ b/lib/FrBr/Common/MooseX/App.pm @@ -321,6 +321,19 @@ sub _log { } +#--------------------------------- + +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; diff --git a/lib/FrBr/Common/MooseX/Role/CommonOpts.pm b/lib/FrBr/Common/MooseX/Role/CommonOpts.pm new file mode 100644 index 0000000..4961f56 --- /dev/null +++ b/lib/FrBr/Common/MooseX/Role/CommonOpts.pm @@ -0,0 +1,335 @@ +package FrBr::Common::MooseX::Role::CommonOpts; + +# $Id$ +# $URL$ + +=head1 NAME + +FrBr::Common::MooseX::Role::CommonOpts + +=head1 DESCRIPTION + +Rolle, um der Basis-Applikation alle Attribute von MooseX::Getopt sowie die +Standard-Kommandozeilenschalter zu verleihen. + +=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 'MooseX::Getopt'; +with 'FrBr::Common::MooseX::Role::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 Attribute + +=cut + +#--------------------------------------------------------------------------- + +has 'show_usage' => ( + is => 'rw', + isa => 'Bool', + lazy => 1, + traits => [ 'Getopt' ], + builder => '_build_show_usage', + documentation => 'BOOL: Anzeige der Verwendung der Anwendung', + cmd_flag => 'help', + cmd_aliases => [ '?', 'usage' ], +); + +sub _build_show_usage { + return 0; +} + +#--------------------------------------------------------------------------- + +has 'version' => ( + is => 'ro', + isa => 'Str', + traits => [ 'NoGetopt' ], + builder => '_build_version', + documentation => 'Versionsstring der Anwendung', +); + +sub _build_version { + return $VERSION; +} + +#--------------------------------------------------------------------------- + +has 'show_version' => ( + is => 'rw', + isa => 'Bool', + lazy => 1, + traits => [ 'Getopt' ], + builder => '_build_show_version', + documentation => 'BOOL: Anzeige der Verwendung der Anwendung', + cmd_flag => 'version', + cmd_aliases => [ 'V' ], +); + +sub _build_show_version { + return 0; +} + +#----------------------------------------- + +has 'verbose' => ( + is => 'rw', + isa => 'UnsignedInt', + traits => [ 'Getopt' ], + lazy => 1, + builder => '_build_verbose', + documentation => 'INT: Ausführlichkeits-Level der Applikation', + cmd_aliases => [ 'D' ], +); + +has 'verbose_bool' => ( + is => 'rw', + isa => 'Bool', + traits => [ 'Getopt' ], + cmd_flag => 'v', + documentation => 'BOOL: Ausführlichkeits-Level der Applikation', +); + +#------ + +sub _build_verbose { + return 0; +} + +#------------------------- + +has 'approot' => ( + is => 'ro', + isa => 'Path::Class::Dir', + traits => [ 'NoGetopt' ], + coerce => 1, + builder => '_build_approot', + documentation => 'Stammverzeichnis der Anwendung', +); + +#------ + +sub _build_approot { + return dir->new( $FindBin::Bin )->parent->absolute; +} + +#------------------------- + +has 'cmd_params' => ( + is => 'ro', + isa => 'Maybe[ArrayRef[Str]]', + traits => [ 'NoGetopt' ], + lazy => 0, + builder => '_build_cmd_params', + documentation => 'Mögliche Kommandozeilenparameter (nicht für GetOpt)', +); + +#------ + +sub _build_cmd_params { + return undef; +} + +#------------------------- + +has 'common_opts_evaluated' => ( + is => 'ro', + isa => 'Bool', + traits => [ 'NoGetopt' ], + builder => '_build_common_opts_evaluated', + writer => '_set_common_opts_evaluated', + documentation => 'Wurden die allgemeinen Kommandozeilen-Optionen bereits ausgewertet', +); + +#------ + +sub _build_common_opts_evaluated { + return 0; +} + +sub _set_common_opts_evaluated { + return $_[1]; +} + +############################################################################ + +=head1 Benötigte Funktionen + +=cut + +requires 'debug'; + +############################################################################ + +=head1 Methoden und Methoden-Modifizerer + +Methoden und Methoden-Modifizerer dieser Rolle + +=head around BUILDARGS + +=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); + +}; + +#--------------------------------------------------------------------------- + +=head 2 after BUILD + +wird nach dem BUILD-Prozess des Anwendungsprozesses aufgerufen + +=cut + +after 'BUILD' => sub { + my $self = shift; + $self->evaluate_common_options(); +}; + +#--------------------------------------------------------------------------- + +sub evaluate_common_options { + + my $self = shift; + + return if $self->common_opts_evaluated; + $self->debug( "Werte allgemeine Optionen aus." ); + + if ( $self->show_usage ) { + $self->do_show_usage(); + exit 0; + } + if ( $self->show_version ) { + $self->do_show_version(); + exit 0; + } + $self->_set_common_opts_evaluated(1); + + return 1; + +} + +#--------------------------------------------------------------------------- + +sub do_show_version { + + my $self = shift; + + print "Version: " . $self->version . "\n"; + +} + +#--------------------------------------------------------------------------- + +sub do_show_usage { + + my $self = shift; + + my @getopt_attrs = grep { + $_->does("MooseX::Getopt::Meta::Attribute::Trait") + or + $_->name !~ /^_/ + } grep { + !$_->does('MooseX::Getopt::Meta::Attribute::Trait::NoGetopt') + } $self->meta->get_all_attributes; + + my @Attribute = (); + my @Short_Opts = (); + my $max_length = 1; + + foreach my $attr ( @getopt_attrs ) { + + my $Attr = {}; + my $lengt = 1; + $self->debug( "Attribut-Objekt: ", $attr ) if $self->verbose >= 4; + + $Attr->{'name'} = $attr->name; + $Attr->{'flag'} = $attr->name; + $Attr->{'aliases'} = []; + if ( $attr->does('MooseX::Getopt::Meta::Attribute::Trait') ) { + $Attr->{'flag'} = $attr->cmd_flag if $attr->has_cmd_flag; + my @aliases = (); + @aliases = @{ $attr->cmd_aliases } if $attr->has_cmd_aliases; + $Attr->{'aliases'} = \@aliases; + } + + $Attr->{'doc'} = $attr->has_documentation ? $attr->documentation : ''; + + push @Short_Opts, $Attr->{'flag'} if length($Attr->{'flag'}) <= 1; + for my $alias ( @{ $Attr->{'aliases'} } ) { + push @Short_Opts, $alias if length($alias) <= 1; + } + $Attr->{'show'} = ''; + for my $opt ( @{ $Attr->{'aliases'} }, $Attr->{'flag'} ) { + $opt = ( length($opt) <= 1 ? '-' : '--' ) . $opt; + $Attr->{'show'} .= ' ' if $Attr->{'show'} ne ''; + $Attr->{'show'} .= $opt; + } + $max_length = length($Attr->{'show'}) if length($Attr->{'show'}) > $max_length; + + $self->debug( "Attribut: ", $Attr ) if $self->verbose >= 3; + push @Attribute, $Attr; + + } + + printf "Verwendung: %s %s[long options]", basename($0), ( @Short_Opts ? ( '[-' . join( '', @Short_Opts ) . '] ' ) : '' ); + print " [" . join( '|', @{ $self->cmd_params } ) . "]" if $self->cmd_params; + print "\n"; + + for my $Attr ( sort { lc($a->{'name'}) cmp lc($b->{'name'}) } @Attribute ) { + printf " %-*s %s\n", $max_length, $Attr->{'show'}, encode_utf8( $Attr->{'doc'} ); + } + +} + + +#--------------------------------------------------------------------------- + +no Moose::Role; +1; + +__END__ + +# vim: noai: filetype=perl ts=4 sw=4 : expandtab diff --git a/lib/FrBr/Common/MooseX/Role/Config.pm b/lib/FrBr/Common/MooseX/Role/Config.pm new file mode 100644 index 0000000..d9f2ed7 --- /dev/null +++ b/lib/FrBr/Common/MooseX/Role/Config.pm @@ -0,0 +1,440 @@ +package OPS::MooseX::Role::Config; + +# $Id$ +# $URL$ + +=head1 NAME + +OPS::MooseX::Role::Config + +=head1 DESCRIPTION + +Rolle, um eine wie auch immer geartete Konfiguration zu integrieren + +=cut + +#--------------------------------------------------------------------------- + +use Moose::Role; + +use MooseX::Getopt::Meta::Attribute::Trait; +use MooseX::Getopt::Meta::Attribute::Trait::NoGetopt; +use Moose::Util::TypeConstraints; +use MooseX::Types::Path::Class; +use File::Basename; +use FindBin; +use Path::Class; +use Clone qw(clone); +use Config::Any; + +use utf8; + +use Carp (); + +#with 'MooseX::Getopt'; +with 'OPS::MooseX::Role::Types'; + +use version; our $VERSION = qv("0.0.1"); + +############################################################################ + +=head1 Attribute + +Eigene Attribute + +=cut + +#------------------------- + +=head2 cfg_stem + +Basisname der Konfigurationsdatei (ohne Endung) im Konfigurationsverzeichnis + +=cut + +has 'cfg_stem' => ( + is => 'ro', + isa => 'Str', + traits => [ 'Getopt' ], + lazy => 1, + builder => '_build_cfg_stem', + documentation => 'Basisname der Konfigurationsdatei (ohne Endung) im Konfigurationsverzeichnis', + cmd_flag => 'config', + cmd_aliases => 'cfg-stem', +); + +#------ + +sub _build_cfg_stem { + return "config"; +} + +#------------------------- + +=head2 cfg_dir + +Verzeichnis der Konfigurationsdateien + +=cut + +has 'cfg_dir' => ( + is => 'rw', + isa => 'Path::Class::Dir', + traits => [ 'NoGetopt' ], + lazy => 1, + builder => '_build_cfg_dir', + documentation => 'Verzeichnis der Konfigurationsdateien', + writer => '_set_cfg_dir', + coerce => 1, + cmd_flag => 'cfg-dir', + cmd_aliases => 'cfgdir', +); + +#------ + +sub _build_cfg_dir { + return dir->new( dir->new( $FindBin::Bin )->parent->absolute, 'etc' ); +} + +#- + +sub _set_cfg_dir { + return dir->new( $_[0] )->absolute; +} + +#--------------------------------- + +=head2 config + +Konfiguration als Hash-Ref nach dem Lesen + +=cut + +has 'config' => ( + is => 'rw', + isa => 'HashRef', + traits => [ 'NoGetopt' ], + lazy => 1, + builder => '_build_config', + documentation => 'Konfiguration als Hash-Ref', +); + +#------ + +sub _build_config { + return {}; +} + +#--------------------------------- + +=head2 default_config + +Vorgabe-Konfiguration als Hash-Ref + +=cut + +has 'default_config' => ( + is => 'ro', + isa => 'HashRef', + traits => [ 'NoGetopt' ], + lazy => 1, + builder => '_build_default_config', + documentation => 'Vorgabe-Konfiguration als Hash-Ref', +); + +#------ + +sub _build_default_config { + return {}; +} + +#--------------------------------- + +=head2 used_cmd_params + +Die tatsächlich mit der Kommandozeile übergebenen Parameter +(besser: ihr dazugehöriger Attributname) als Key, Value immer 1 + +=cut + +has 'used_cmd_params' => ( + is => 'rw', + isa => 'HashRef', + traits => [ 'NoGetopt' ], + lazy => 1, + builder => '_build_used_cmd_params', + documentation => 'Die tatsächlich mit der Kommandozeile übergebenen Parameter (besser: ihr dazugehöriger Attributname) als Key, Value immer 1', +); + +#------ + +sub _build_used_cmd_params { + return {}; +} + +#------------------------- + +=head2 configuration_evaluated + +Wurde die Konfiguration bereits ausgewertet? + +=cut + +has 'configuration_evaluated' => ( + is => 'ro', + isa => 'Bool', + traits => [ 'NoGetopt' ], + builder => '_build_configuration_evaluated', + writer => '_set_configuration_evaluated', + documentation => 'Wurde die Konfiguration bereits ausgewertet', +); + +#------ + +sub _build_configuration_evaluated { + return 0; +} + +sub _set_configuration_evaluated { + return $_[1]; +} + +#------------------------- + +=head2 configuration_read + +Wurde die Konfiguration bereits gelesen? + +=cut + +has 'configuration_read' => ( + is => 'ro', + isa => 'Bool', + traits => [ 'NoGetopt' ], + builder => '_build_configuration_read', + writer => '_set_configuration_read', + documentation => 'Wurde die Konfiguration bereits gelesen', +); + +#------ + +sub _build_configuration_read { + return 0; +} + +sub _set_configuration_read { + return $_[1]; +} + +############################################################################ + +=head1 Benötigte Funktionen + +=cut + +#requires 'debug'; + +#--------------------------------------------------------------------------- + +# Ändern der Eigenschaften einiger geerbter Attribute + +############################################################################ + +=head1 Methoden und Methoden-Modifizerer + +Methoden und Methoden-Modifizerer dieser Rolle + +=cut + +#--------------------------------------------------------------------------- + +=head 2 after BUILD + +wird nach dem BUILD-Prozess des Anwendungsprozesses aufgerufen + +=cut + +#after 'BUILD' => sub { +# my $self = shift; +# $self->read_config_file(); +# $self->evaluate_config(); +#}; + +sub BUILD { + my $self = shift; + $self->read_config_file(); + $self->evaluate_config(); +} + +#--------------------------------------------------------------------------- + +=head2 read_config_file( [$force] ) + +Liest die Konfiguration aus den Konfigurations-Dateien ein. + +Der boolsche Parameter $force besagt, wenn mit einem wahren Wert übergeben, +dass die Konfiguration eingelesen werden soll, auch wenn sie bereits +gelesen wurde. + +=cut + +sub read_config_file { + + my $self = shift; + my $force = shift; + + unless ( $force ) { + return if $self->configuration_read; + } + + $self->debug( "Lese Konfiguration ..." ); + + my $config = clone($self->default_config()); + + my $stems = [ file( $self->cfg_dir, $self->cfg_stem )->stringify ]; + + $self->debug( "Versuche Config-STEMS zu lesen: ", $stems ) if $self->verbose > 3; + my $cfg = Config::Any->load_stems( { stems => $stems, flatten_to_hash => 0, use_ext => 1 } ); + $self->debug( "Gelesene Konfiguration: ", $cfg ) if $self->verbose > 3; + + for my $file ( keys %$cfg ) { + if ( keys %{ $cfg->{$file} } ) { + $config = merge_hashes( $config, $cfg->{$file} ); + } + } + + $stems = [ file( $self->cfg_dir, ( $self->cfg_stem . "_local" ) )->stringify ]; + $self->debug( "Versuche lokale Config-STEMS zu lesen: ", $stems ) if $self->verbose > 3; + $cfg = Config::Any->load_stems( { stems => $stems, flatten_to_hash => 0, use_ext => 1 } ); + $self->debug( "Gelesene lokale Konfiguration: ", $cfg ) if $self->verbose > 3; + + for my $file ( keys %$cfg ) { + if ( keys %{ $cfg->{$file} } ) { + $config = merge_hashes( $config, $cfg->{$file} ); + } + } + + $self->debug( "Zusammengemixte Konfiguration: ", $config ) if $self->verbose > 2; + + $self->config($config); + + $self->_set_configuration_read(1); + $self->_set_configuration_evaluated(0); + +} + +#--------------------------------- + +=head2 evaluate_config( ) + +Wertet die gelesene Konfiguration aus. + +=cut + +sub evaluate_config { + + my $self = shift; + + return if $self->configuration_evaluated; + + if ( $self->config and keys %{ $self->config } ) { + $self->config->{'log'}{'dir'} = dir->new( $self->basedir, 'log' )->stringify unless $self->config->{'log'}{'dir'}; + $self->config->{'log'}{'stderror'} = 'error.log' unless exists $self->config->{'log'}{'stderror'}; + } + + $self->used_cmd_params( {} ); + my $used_cmd_params = $self->used_cmd_params; + + my @getopt_attrs = grep { + $_->does("MooseX::Getopt::Meta::Attribute::Trait") + or + $_->name !~ /^_/ + } grep { + !$_->does('MooseX::Getopt::Meta::Attribute::Trait::NoGetopt') + } $self->meta->get_all_attributes; + + my %Attribute = (); + + foreach my $attr ( @getopt_attrs ) { + + my $Attr = {}; + + my $name = $attr->name; + my $flag = $attr->name; + my $aliases = []; + + if ( $attr->does('MooseX::Getopt::Meta::Attribute::Trait') ) { + $flag = $attr->cmd_flag if $attr->has_cmd_flag; + @$aliases = @{ $attr->cmd_aliases } if $attr->has_cmd_aliases; + } + + for my $opt ( @$aliases, $flag ) { + my $n_opt = ( length($opt) <= 1 ? '-' : '--' ) . $opt; + $Attribute{$n_opt} = $name; + if ( $attr->{'isa'} eq 'Bool' ) { + $n_opt = '--no' . $opt; + $Attribute{$n_opt} = $name; + } + } + + } + + for my $param ( @{ $self->ARGV } ) { + if ( $Attribute{$param} ) { + my $name = $Attribute{$param}; + $used_cmd_params->{$name} = 1; + } + } + + unless ( $self->used_cmd_params->{'production_state'} ) { + my $state = $self->config->{'production_state'} || $self->config->{'production-state'} || undef; + $self->production_state( $state ) if $state; + } + + + + $self->_set_configuration_evaluated(1); + + 1; +} + +#--------------------------------- + +=head2 merge_hashes($hashref, $hashref) + +Base code to recursively merge two hashes together with right-hand precedence. + +=cut + +sub merge_hashes { + + my ( $lefthash, $righthash ) = @_; + + return $lefthash unless defined $righthash; + + my %merged = %$lefthash; + for my $key ( keys %$righthash ) { + my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH'; + my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH'; + if( $right_ref and $left_ref ) { + $merged{ $key } = merge_hashes( + $lefthash->{ $key }, $righthash->{ $key } + ); + } + else { + $merged{ $key } = $righthash->{ $key }; + } + } + + return \%merged; + +} + +#--------------------------------------------------------------------------- + +no Moose::Role; +1; + +__END__ + +# vim: noai: filetype=perl ts=4 sw=4 : expandtab diff --git a/lib/FrBr/Common/MooseX/Role/Types.pm b/lib/FrBr/Common/MooseX/Role/Types.pm new file mode 100644 index 0000000..0ec8e14 --- /dev/null +++ b/lib/FrBr/Common/MooseX/Role/Types.pm @@ -0,0 +1,65 @@ +package FrBr::Common::MooseX::Role::Types; + +# $Id$ +# $URL$ + +=head1 NAME + +FrBr::Common::MooseX::Role::Types + +=head1 DESCRIPTION + +Definiert alle speziellen Attributtypen + +=cut + +#--------------------------------------------------------------------------- + +use Moose::Role; + +use Moose::Util::TypeConstraints; + +use Carp (); +use Params::Coerce (); +use URI (); + +#--------------------------------------------------------------------------- + +subtype 'UnsignedInt' + => as 'Int' + => where { $_ >= 0 } + => message { "Die von Ihnen angegebene Zahl '$_' ist negativ." }; + +subtype 'DBIx::Class::Schema' + => as 'Object' + => where { $_->isa('DBIx::Class::Schema') } + => message { "Das übergebene Objekt muss vom Typ 'DBIx::Class::Schema' sein" }; + +subtype 'Number::Format' + => as 'Object' + => where { $_->isa('Number::Format') } + => message { "Das übergebene Objekt muss vom Typ 'Number::Format' sein" }; + +subtype 'XML::Simple' + => as 'Object' + => where { $_->isa('XML::Simple') } + => message { "Das übergebene Objekt muss vom Typ 'XML::Simple' sein" }; + +subtype 'FrBr::Types::URI' => as class_type('URI'); + +coerce 'FrBr::Types::URI' + => from 'Object' + => via { $_->isa('URI') ? $_ : Params::Coerce::coerce( 'URI', $_ ); } + => from 'Str' + => via { URI->new( $_, 'http' ) }; + +#--------------------------------------------------------------------------- + +no Moose::Role; +1; + +__END__ + + + +# vim: noai: filetype=perl ts=4 sw=4 : expandtab -- 2.39.5