File Coverage

blib/lib/DhMakePerl/Config.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package DhMakePerl::Config;
2              
3 1     1   157033 use strict;
  1         4  
  1         99  
4 1     1   14 use warnings;
  1         1  
  1         419  
5              
6             our $VERSION = '0.77';
7              
8             =head1 NAME
9              
10             DhMakePerl::Config - dh-make-perl configuration class
11              
12             =cut
13              
14 1     1   92 use base 'Class::Accessor';
  1         3  
  1         1210  
15 1     1   4038 use Dpkg::Source::Package;
  0            
  0            
16              
17             my @OPTIONS = (
18             'apt-contents-dir=s',
19             'arch=s', 'backups!',
20             'basepkgs=s',
21             'bdepends=s', 'bdependsi=s',
22             'build-source!',
23             'build!', 'closes=i',
24             'config-file=s', 'core-ok',
25             'cpan-mirror=s', 'cpan=s',
26             'cpanplus=s', 'data-dir=s',
27             'dbflags=s', 'depends=s',
28             'desc=s', 'dh=i',
29             'dist=s', 'email|e=s',
30             'exclude|i:s{,}',
31             'home-dir=s', 'install!',
32             'intrusive!',
33             'network!',
34             'nometa', 'notest',
35             'only|o=s@',
36             'packagename|p=s', 'pkg-perl!',
37             'recursive!',
38             'requiredeps', 'sources-list=s',
39             'source-format=s', 'vcs=s',
40             'verbose!', 'version=s',
41             );
42              
43             my @COMMANDS =
44             ( 'make', 'refresh|R', 'refresh-cache', 'dump-config', 'locate', 'help' );
45              
46             __PACKAGE__->mk_accessors(
47             do {
48             my @opts = ( @OPTIONS, @COMMANDS );
49             for (@opts) {
50             s/[=:!|].*//;
51             s/-/_/g;
52             }
53             @opts;
54             },
55             'command',
56             'cpan2deb',
57             'cpan2dsc',
58             '_explicitly_set',
59             );
60              
61             use File::Basename qw(basename);
62             use File::Spec::Functions qw(catfile);
63             use Getopt::Long;
64             use Tie::IxHash ();
65             use YAML ();
66              
67             use constant DEFAULTS => {
68             backups => 1,
69             data_dir => '/usr/share/dh-make-perl',
70             dbflags => ( $> == 0 ? "" : "-rfakeroot" ),
71             dh => 9,
72             dist => '',
73             email => '',
74             exclude => qr/$Dpkg::Source::Package::diff_ignore_default_regexp/,
75             home_dir => "$ENV{HOME}/.dh-make-perl",
76             network => 1,
77             only => {
78             map (
79             ( $_ => 1 ),
80             qw(control copyright docs examples rules)
81             ),
82             },
83             source_format => '3.0 (quilt)',
84             vcs => 'git',
85             verbose => 1,
86             };
87              
88             use constant cpan2deb_DEFAULTS => {
89             build => 1,
90              
91             #recursive => 1,
92             };
93              
94             use constant cpan2dsc_DEFAULTS => {
95             build_source => 1,
96              
97             #recursive => 1,
98             };
99              
100             sub new {
101             my $class = shift;
102             my $values = shift || {};
103              
104             my $cpan2deb = basename($0) eq 'cpan2deb';
105             my $cpan2dsc = basename($0) eq 'cpan2dsc';
106              
107             my $self = $class->SUPER::new(
108             { %{ $class->DEFAULTS },
109             ( $cpan2deb
110             ? %{ $class->cpan2deb_DEFAULTS }
111             : ()
112             ),
113             ( $cpan2dsc
114             ? %{ $class->cpan2dsc_DEFAULTS }
115             : ()
116             ),
117             cpan2deb => $cpan2deb,
118             cpan2dsc => $cpan2dsc,
119             %$values,
120             },
121             );
122              
123             $self->_explicitly_set( {} ) unless $self->_explicitly_set;
124              
125             return $self;
126             }
127              
128             =head1 METHODS
129              
130             =over
131              
132             =item parse_command_line_options()
133              
134             Parses command line options and populates object members.
135              
136             =cut
137              
138             sub parse_command_line_options {
139             my $self = shift;
140              
141             # first get 'regular' options. commands are parsed in another
142             # run below.
143             Getopt::Long::Configure( qw( pass_through no_auto_abbrev no_ignore_case ) );
144             my %opts;
145             GetOptions( \%opts, @OPTIONS )
146             or die "Error parsing command-line options\n";
147              
148             # "If no argument is given (but the switch is specified - not specifying
149             # the switch will include everything), it defaults to dpkg-source's
150             # default values."
151             $opts{exclude} = '^$' if ! defined $opts{exclude}; # switch not specified
152             # take everything
153             $opts{exclude} = $self->DEFAULTS->{'exclude'} if ! $opts{exclude}; # arguments not specified
154             # back to defaults
155              
156             # handle comma-separated multiple values in --only
157             $opts{only}
158             = { map ( ( $_ => 1 ), split( /,/, join( ',', @{ $opts{only} } ) ) ) }
159             if $opts{only};
160              
161             while ( my ( $k, $v ) = each %opts ) {
162             my $field = $k;
163             $field =~ s/-/_/g;
164             $self->$field( $opts{$k} );
165             $self->_explicitly_set->{$k} = 1;
166             }
167              
168             # see what are we told to do
169             %opts = ();
170             Getopt::Long::Configure('no_pass_through');
171             GetOptions( \%opts, @COMMANDS )
172             or die "Error parsing command-line options\n";
173              
174             if (%opts) {
175             my $cmd = ( keys %opts )[0];
176             warn "WARNING: double dashes in front of sub-commands are deprecated\n";
177             warn "WARNING: for instance, use '$cmd' instead of '--$cmd'\n";
178             }
179             else {
180             my %cmds;
181             for (@COMMANDS) {
182             my $c = $_;
183             $c =~ s/\|.+//; # strip short alternatives
184             $cmds{$c} = 1;
185             }
186              
187             # treat the first non-option as command
188             # if it looks like one
189             $opts{ shift(@ARGV) } = 1
190             if $ARGV[0]
191             and $cmds{ $ARGV[0] };
192              
193             # by default, create source package
194             $opts{make} = 1 unless %opts;
195             }
196              
197             if ( scalar( keys %opts ) > 1 ) {
198             die "Only one of " .
199             join(', ', @COMMANDS ) . " can be specified\n";
200             }
201              
202             $self->command( ( keys %opts )[0] );
203              
204             $self->verbose(1)
205             if $self->command eq 'make'
206             and not $self->_explicitly_set->{verbose};
207              
208             if ($self->cpan2deb) {
209             @ARGV == 1 or die "cpan2deb requires exactly one non-option argument";
210              
211             $self->cpan( shift @ARGV );
212             $self->_explicitly_set->{cpan} = 1;
213             $self->build(1);
214             $self->command('make');
215             }
216              
217             if ($self->cpan2dsc) {
218             @ARGV == 1 or die "cpan2dsc requires exactly one non-option argument";
219              
220             $self->cpan( shift @ARGV );
221             $self->_explicitly_set->{cpan} = 1;
222             $self->build_source(1);
223             $self->command('make');
224             }
225              
226             # Make CPAN happy, make the user happy: Be more tolerant!
227             # Accept names to be specified with double-colon, dash or slash
228             if ( my $name = $self->cpan ) {
229             $name =~ s![/-]!::!g;
230             $self->cpan($name);
231             }
232              
233             $self->check_obsolete_entries;
234             }
235              
236             =item parse_config_file()
237              
238             Parse configuration file. I member is used for location the file,
239             if not set, F file in I is used.
240              
241             =cut
242              
243             sub parse_config_file {
244             my $self = shift;
245              
246             my $fn = $self->config_file
247             || catfile( $self->home_dir, 'dh-make-perl.conf' );
248              
249             if ( -e $fn ) {
250             local $@;
251             my $yaml = eval { YAML::LoadFile($fn) };
252              
253             die "Error parsing $fn: $@" if $@;
254              
255             die
256             "Error parsing $fn: config-file is not allowed in the configuration file"
257             if $yaml->{'config-file'};
258              
259             for (@OPTIONS) {
260             ( my $key = $_ ) =~ s/[!=|].*//;
261              
262             next unless exists $yaml->{$key};
263              
264             my $value = delete $yaml->{$key};
265             next
266             if $self->_explicitly_set
267             ->{$key}; # cmd-line opts take precedence
268              
269             ( my $opt = $key ) =~ s/-/_/g;
270             $self->$opt($value);
271             }
272              
273             die "Error parsing $fn: the following keys are not known:\n"
274             . join( "\n", map( " - $_", keys %$yaml ) )
275             if %$yaml;
276              
277             $self->check_obsolete_entries;
278             }
279             }
280              
281             =item dump_config()
282              
283             Returns a string representation of all configuration options. Suitable for
284             populating configuration file.
285              
286             =cut
287              
288             sub dump_config {
289             my $self = shift;
290              
291             my %hash;
292             tie %hash, 'Tie::IxHash';
293              
294             for my $opt (@OPTIONS) {
295             $opt =~ s/[=!|].*//;
296             ( my $field = $opt ) =~ s/-/_/g;
297             $hash{$opt} = $self->$field;
298             }
299              
300             local $YAML::UseVersion = 1;
301             local $YAML::Stringify = 1;
302              
303             return YAML::Dump( \%hash );
304             }
305              
306             =item check_obsolete_entries
307              
308             Checks for presence of deprecated/obsolete entries and warns/dies if any is
309             found.
310              
311             =cut
312              
313             sub check_obsolete_entries {
314             my ($self) = @_;
315              
316             warn "--notest ignored. if you don't want to run the tests when building the package, add 'nocheck' to DEB_BUILD_OPTIONS\n"
317             if $self->notest;
318              
319             if ( $self->dh < 8 ) {
320             warn "debhelper compatibility levels before 8 are not supported.\n";
321             exit(1);
322             }
323             }
324              
325             =back
326              
327             =head1 COPYRIGHT & LICENSE
328              
329             =over
330              
331             =item Copyright (C) 2008-2010 Damyan Ivanov
332              
333             =item Copyright (C) 2009-2010 Gregor Herrmann
334              
335             =item Copyright (C) 2009 Ryan Niebur
336              
337             =back
338              
339             This program is free software; you can redistribute it and/or modify it under
340             the terms of the GNU General Public License version 2 as published by the Free
341             Software Foundation.
342              
343             This program is distributed in the hope that it will be useful, but WITHOUT ANY
344             WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
345             PARTICULAR PURPOSE. See the GNU General Public License for more details.
346              
347             You should have received a copy of the GNU General Public License along with
348             this program; if not, write to the Free Software Foundation, Inc., 51 Franklin
349             Street, Fifth Floor, Boston, MA 02110-1301 USA.
350              
351             =cut
352              
353             1;