This is an automated email from the git hooks/post-receive script. dmn pushed a commit to branch master in repository dh-make-perl.
commit e6e6767e0bdbd25106bd1584f724c034836b7129 Author: Damyan Ivanov <d...@debian.org> Date: Mon Dec 4 21:28:59 2017 +0000 Debian::Control::Stanza: add support for user-defined fields (X-Moon-Phase) Closes: #883439 --- Build.PL | 1 + debian/control | 2 ++ lib/Debian/Control/Stanza.pm | 60 ++++++++++++++++++++++++++++++++++++- lib/Debian/Control/Stanza/Source.pm | 4 +-- t/Control.t | 18 +++++++++-- 5 files changed, 79 insertions(+), 6 deletions(-) diff --git a/Build.PL b/Build.PL index 89e9a9c..ebdbbb5 100644 --- a/Build.PL +++ b/Build.PL @@ -50,6 +50,7 @@ my $builder = My::Builder->new( 'Parse::DebianChangelog' => 0, 'Software::License::Artistic_2_0' => 0, 'Storable' => 0, + 'Sub::Install' => 0, 'Sys::CPU' => 0, 'Text::Diff' => 0, 'Text::Wrap' => 0, diff --git a/debian/control b/debian/control index 6fd0103..709313c 100644 --- a/debian/control +++ b/debian/control @@ -29,6 +29,7 @@ Build-Depends-Indep: libapt-pkg-perl, libparse-debcontrol-perl, libparse-debianchangelog-perl, libsoftware-license-perl, + libsub-install-perl, libsys-cpu-perl, libtest-compile-perl, libtest-deep-perl, @@ -107,6 +108,7 @@ Depends: ${misc:Depends}, libclass-accessor-perl, liblist-moreutils-perl, libparse-debcontrol-perl, + libsub-install-perl, libtie-ixhash-perl, libwww-mechanize-perl, libwww-perl diff --git a/lib/Debian/Control/Stanza.pm b/lib/Debian/Control/Stanza.pm index 5a70fa9..996ba43 100644 --- a/lib/Debian/Control/Stanza.pm +++ b/lib/Debian/Control/Stanza.pm @@ -32,6 +32,7 @@ use base qw( Class::Accessor Tie::IxHash ); use Carp qw(croak); use Debian::Control::Stanza::CommaSeparated; use Debian::Dependencies; +use Sub::Install; =head1 FIELDS @@ -44,6 +45,15 @@ Fields that are to contain dependency lists (as per L</is_dependency_list> method below) are automatically converted to instances of the L<Debian::Dependencies> class. +=head2 User-defined fields + +User-defined fields are supported. These start with C<X>, optionally followed +by C<S>, C<B> or C<C>, then C<_>, capital letter and other letters and digits. + +Examples: C<X_Moon_Phase>, C<XS_Hemisphere>. + +See L<https://www.debian.org/doc/debian-policy/#user-defined-fields>. + =cut use constant fields => (); @@ -98,6 +108,7 @@ sub new { # translate field name into the accessor canonical name $k = $canonical{ lc $k } || $k; $self->can($k) + or $self->looks_like_an_x_field($k) or croak "Invalid field given ($k)"; $self->$k($v); } @@ -117,6 +128,40 @@ sub new { return $self; } +our $AUTOLOAD; +sub AUTOLOAD { + my $self = shift; + + ref($self) and eval { $self->isa(__PACKAGE__) } + or croak "Invalid method call"; + + my $field = $AUTOLOAD; + $field =~ s/.+:://; + + if ( $field eq 'DESTROY' ) { + return eval { $self->SUPER::DESTROY(@_) }; + } + + $self->looks_like_an_x_field($field) + or croak "Invalid field '$field' requested"; + + Sub::Install::install_sub({ + code => sub { + my $self = shift; + if (@_) { + $self->set( $field, @_ ); + } + else { + $self->get($field); + } + }, + into => ref($self), + as => $field, + }); + + $self->$field(@_); +} + =head1 METHODS =over @@ -202,6 +247,19 @@ sub is_comma_separated { return exists $comma_separated{$field}; } +=item looks_like_an_x_field($field) + +Returns true if B<$field> is considered appropriate to name a user-defined +field. + +=cut + +sub looks_like_an_x_field { + my ( $self, $field ) = @_; + + return $field =~ /^X[SBC]?(?:_[A-Z][A-Za-z0-9]*)+$/; +} + =item get($field) Overrides the default get method from L<Class::Accessor> with L<Tie::IxHash>'s @@ -322,7 +380,7 @@ sub as_string =head1 COPYRIGHT & LICENSE -Copyright (C) 2009 Damyan Ivanov L<d...@debian.org> +Copyright (C) 2009, 2017 Damyan Ivanov L<d...@debian.org> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License version 2 as published by the Free diff --git a/lib/Debian/Control/Stanza/Source.pm b/lib/Debian/Control/Stanza/Source.pm index c219ad5..c7d815d 100644 --- a/lib/Debian/Control/Stanza/Source.pm +++ b/lib/Debian/Control/Stanza/Source.pm @@ -61,8 +61,6 @@ replaced with underscores. =item Homepage -=item XS_Autobuild - =item Testsuite =item Rules_Requires_Root @@ -87,7 +85,7 @@ use constant fields => qw ( Source Section Priority Maintainer Uploaders DM_Upload_Allowed Build_Conflicts Build_Conflicts_Indep Build_Depends Build_Depends_Indep Standards_Version Vcs_Browser Vcs_Bzr Vcs_CVS Vcs_Git Vcs_Svn Homepage - XS_Autobuild Testsuite Rules_Requires_Root + Testsuite Rules_Requires_Root ); =head1 CONSTRUCTOR diff --git a/t/Control.t b/t/Control.t index b27eec6..8dbff54 100644 --- a/t/Control.t +++ b/t/Control.t @@ -116,12 +116,26 @@ EOF lives_ok { $s = Debian::Control::Stanza::Source->new({'Vcs_Git' => 'git://example.org'}) } 'Source constructor with Vcs_Git'; can_ok($s, qw(Vcs_Git)); ok($s->Vcs_Git eq 'git://example.org', 'Vcs_Git returns correct value'); -throws_ok { $s->vCs_GiT } qr/Can't locate object method "vCs_GiT" via package "Debian::Control::Stanza::Source"/, 'No method vCs_GiT'; +throws_ok { $s->vCs_GiT } qr/Invalid field 'vCs_GiT' requested/, 'No vCs_GiT field'; lives_ok { $s = Debian::Control::Stanza::Source->new({'vCs-GiT' => 'git://example.net'}) } 'Source constructor with vCs-GiT'; can_ok($s, qw(Vcs_Git)); ok($s->Vcs_Git eq 'git://example.net', 'Vcs_Git returns correct value'); -throws_ok { $s->vCs_GiT } qr/Can't locate object method "vCs_GiT" via package "Debian::Control::Stanza::Source"/, 'No method vCs_GiT'; +throws_ok { $s->vCs_GiT } qr/Invalid field 'vCs_GiT' requested/, 'No method vCs_GiT'; +ok( $s->looks_like_an_x_field('XS_Moon_Phase'), + "XS_Moon_Phase looks like an X_ field" +); + +ok( $s->looks_like_an_x_field('X_Hemisphere'), + "X_emisphere looks like an X_ field" +); + +ok( !$s->looks_like_an_x_field('XFail'), + "XFail doesn't look like an X_ field" +); + +lives_ok { $s->XS_Moon_Phase("full") } "Can set XS_Moon_Phase"; +is( $s->XS_Moon_Phase, 'full', 'Moon is full' ); done_testing; -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/dh-make-perl.git _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits