From ab9737dbee616cf425986a6ff0e4489234e4403a Mon Sep 17 00:00:00 2001 From: Frank Brehm Date: Thu, 1 Apr 2010 15:14:19 +0000 Subject: [PATCH] Erste Rollenmodule git-svn-id: http://svn.brehm-online.com/svn/my-stuff/Perl@46 ec8d2aa5-1599-4edb-8739-2b3a1bc399aa --- lib/FrBr/Common/MooseX/CommonOpts.pm | 288 +++++++++++++++++++++++++++ lib/FrBr/Common/MooseX/Types.pm | 50 +++++ 2 files changed, 338 insertions(+) create mode 100644 lib/FrBr/Common/MooseX/CommonOpts.pm create mode 100644 lib/FrBr/Common/MooseX/Types.pm diff --git a/lib/FrBr/Common/MooseX/CommonOpts.pm b/lib/FrBr/Common/MooseX/CommonOpts.pm new file mode 100644 index 0000000..720a338 --- /dev/null +++ b/lib/FrBr/Common/MooseX/CommonOpts.pm @@ -0,0 +1,288 @@ +package FrBr::Common::MooseX::CommonOpts; + +# $Id$ +# $URL$ + +=head1 NAME + +FrBr::Common::MooseX::CommonOpts; + +=head1 DESCRIPTION + +Rollen-Modul zur Einbindung von GetOpt und damit verbundenen allgemeinen Attributen +und Kommandozeilenoptionen. + +=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::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 show_usage + +=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; +} + +#--------------------------------------------------------------------------- + +=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); + +}; + +#--------------------------------------------------------------------------- + +sub evaluate_common_options { + + my $self = shift; + +# $self->debug( "Werte allgemeine Optionen aus." ); + + $self->_do_show_usage() if $self->show_usage; + $self->_do_show_version() if $self->show_version; + + return 1; + +} + +#--------------------------------------------------------------------------- + +sub _do_show_version { + + my $self = shift; + + print "Version: " . $self->version . "\n"; + exit 0; + +} + +#--------------------------------------------------------------------------- + +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; + + $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'} ); + } + + exit 0; + +} + +#--------------------------------------------------------------------------- + +no Moose::Role; +1; + +__END__ + +# vim: noai: filetype=perl ts=4 sw=4 : expandtab diff --git a/lib/FrBr/Common/MooseX/Types.pm b/lib/FrBr/Common/MooseX/Types.pm new file mode 100644 index 0000000..d97af10 --- /dev/null +++ b/lib/FrBr/Common/MooseX/Types.pm @@ -0,0 +1,50 @@ +package FrBr::Common::MooseX::Types; + +# $Id$ +# $URL$ + +=head1 NAME + +FrBr::Common::MooseX::Types + +=head1 DESCRIPTION + +Definiert alle speziellen Attributtypen + +=cut + +#--------------------------------------------------------------------------- + +use Moose::Role; +use Moose::Util::TypeConstraints; + +use Carp (); + +#--------------------------------------------------------------------------- + +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" }; + +#--------------------------------------------------------------------------- + +no Moose::Role; +1; + +# vim: noai: filetype=perl ts=4 sw=4 : expandtab -- 2.39.5