1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137
|
package Config::Model::Itself::BackendDetector ;
# since this package is mostly targeted for dev environments
# let the detector detect models under development
use lib 'lib';
use Pod::POM ;
use File::Find ;
use base qw/Config::Model::Value/ ;
use strict ;
use warnings ;
sub setup_enum_choice {
my $self = shift ;
# using a hash to make sure that a backend is not listed twice. This may
# happen in development environment where a backend in found in /usr/lib
# and in ./lib (or ./blib)
my %choices = map { ($_ => 1);} ref $_[0] ? @{$_[0]} : @_ ;
# find available backends in all @INC directories
my $wanted = sub {
my $n = $File::Find::name ;
if (-f $_ and $n =~ s/\.pm$// and $n !~ /Any$/) {
$n =~ s!.*Backend/!! ;
$n =~ s!/!::!g ;
$choices{$n} = 1 ;
}
} ;
foreach my $inc (@INC) {
my $path = "$inc/Config/Model/Backend" ;
find ($wanted, $path ) if -d $path;
}
$self->SUPER::setup_enum_choice(sort keys %choices) ;
}
sub set_help {
my ($self,$args) = @_ ;
my $help = delete $args->{help} || {} ;
my $path = $INC{"Config/Model.pm"} ;
$path =~ s!\.pm!/Backend! ;
my $parser = Pod::POM->new();
my $wanted = sub {
my $n = $File::Find::name ;
return unless (-f $n and $n !~ /Any\.pm$/) ;
my $file = $n ;
$n =~ s/\.pm$//;
$n =~ s!/!::!g ;
my $perl_name = $n ;
$n =~ s!.*Backend::!! ;
$perl_name =~ s!.*Config!Config! ;
my $pom = $parser->parse_file($file)|| die $parser->error();
foreach my $head1 ($pom->head1()) {
if ($head1->title() eq 'NAME') {
my $c = $head1->content();
$c =~ s/.*?-\s*//;
$c =~ s/\n//g;
$help->{$n} = $c . " provided by L<$perl_name>";
last;
}
}
};
find ($wanted, $path ) ;
$self->{help} = $help;
}
1;
# ABSTRACT: Detect available read/write backends usable by config models
__END__
=head1 SYNOPSIS
# this class should be referenced in a configuration model and
# created only by Config::Model::Node
my $model = Config::Model->new() ;
$model ->create_config_class
(
name => "Test",
'element'
=> [
'backend' => { type => 'leaf',
class => 'Config::Model::Itself::BackendDetector' ,
value_type => 'enum',
# specify backends built in Config::Model
choice => [qw/cds_file perl_file ini_file custom/],
help => {
cds_file => "file ...",
ini_file => "Ini file ...",
perl_file => "file perl",
custom => "Custom format",
}
}
],
);
my $root = $model->instance(root_class_name => 'Test') -> config_root ;
my $backend = $root->fetch_element('backend') ;
my @choices = $backend->get_choice ;
=head1 DESCRIPTION
This class is derived from L<Config::Model::Value>. It is designed to
be used in a 'enum' value where the choice (the available backends)
are the backend built in L<Config::Model> and all the plugin backends. The
plugin backends are all the C<Config::Model::Backend::*> classes.
This module will detect available plugin backend and query their pod
documentation to provide a contextual help for config-model graphical
editor.
=head1 SEE ALSO
L<Config::Model>, L<Config::Model::Node>, L<Config::Model::Value>
=cut
|