[boxer] 11/33: Add World and Part classes, with unit test.
Jonas Smedegaard
dr at jones.dk
Sun Nov 5 18:28:17 UTC 2017
This is an automated email from the git hooks/post-receive script.
js pushed a commit to annotated tag debian/1.1.5-1
in repository boxer.
commit 393f8da7190245f8222b4ffd0dcaf99e36c1be23
Author: Jonas Smedegaard <dr at jones.dk>
Date: Sat Jul 2 03:49:20 2016 +0200
Add World and Part classes, with unit test.
---
lib/Boxer/CLI/Command/Compose.pm | 6 +-
lib/Boxer/Part.pm | 64 +++++++++++++
lib/Boxer/Part/Reclass.pm | 125 +++++++++++++++++++++++++
lib/Boxer/Task/Classify.pm | 18 +++-
lib/Boxer/Task/Serialize.pm | 119 +++---------------------
lib/Boxer/World.pm | 73 +++++++++++++++
lib/Boxer/World/Reclass.pm | 195 +++++++++++++++++++++++++++++++++++++++
t/world.t | 62 +++++++++++++
8 files changed, 552 insertions(+), 110 deletions(-)
diff --git a/lib/Boxer/CLI/Command/Compose.pm b/lib/Boxer/CLI/Command/Compose.pm
index a2bbe6c..97d31db 100644
--- a/lib/Boxer/CLI/Command/Compose.pm
+++ b/lib/Boxer/CLI/Command/Compose.pm
@@ -10,6 +10,7 @@ use strictures 2;
use version;
use Role::Commons -all;
+use Path::Tiny;
use Module::Runtime qw/use_module/;
use Boxer::CLI -command;
@@ -66,7 +67,7 @@ sub execute
my $self = shift;
my ( $opt, $args ) = @_;
- my $data = use_module('Boxer::Task::Classify')->new(
+ my $world = use_module('Boxer::Task::Classify')->new(
suite => $opt->{suite},
nodedir => $opt->{nodedir},
classdir => $opt->{classdir},
@@ -74,10 +75,9 @@ sub execute
)->run;
for my $node (@$args) {
use_module('Boxer::Task::Serialize')->new(
+ world => $world,
skeldir => $opt->{skeldir},
- suite => $opt->{suite},
nonfree => $opt->{nonfree},
- data => $data,
node => $node,
)->run;
}
diff --git a/lib/Boxer/Part.pm b/lib/Boxer/Part.pm
new file mode 100644
index 0000000..1048065
--- /dev/null
+++ b/lib/Boxer/Part.pm
@@ -0,0 +1,64 @@
+package Boxer::Part;
+
+=encoding UTF-8
+
+=head1 NAME
+
+Boxer::Part - software component
+
+=cut
+
+use v5.14;
+use utf8;
+use strictures 2;
+use version;
+use Role::Commons -all;
+use autodie;
+
+use Moo;
+
+use namespace::clean;
+
+=head1 VERSION
+
+Version v1.1.4
+
+=cut
+
+our $VERSION = version->declare("v1.1.4");
+
+=head1 DESCRIPTION
+
+Outside the box is a World of software,
+consisting of parts.
+
+B<Boxer::Part> represents a part of a <Boxer::World>.
+
+=head1 SEE ALSO
+
+L<Boxer>.
+
+=head1 AUTHOR
+
+Jonas Smedegaard C<< <dr at jones.dk> >>.
+
+=cut
+
+our $AUTHORITY = 'cpan:JONASS';
+
+=head1 COPYRIGHT AND LICENCE
+
+Copyright © 2013-2016 Jonas Smedegaard
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+=cut
+
+1;
diff --git a/lib/Boxer/Part/Reclass.pm b/lib/Boxer/Part/Reclass.pm
new file mode 100644
index 0000000..cd638e4
--- /dev/null
+++ b/lib/Boxer/Part/Reclass.pm
@@ -0,0 +1,125 @@
+package Boxer::Part::Reclass;
+
+=encoding UTF-8
+
+=head1 NAME
+
+Boxer::Part::Reclass - software component as a reclass node or class
+
+=cut
+
+use v5.14;
+use utf8;
+use strictures 2;
+use version;
+use Role::Commons -all;
+use autodie;
+
+use Moo;
+extends 'Boxer::Part';
+use Types::Standard qw(Str Maybe ArrayRef HashRef);
+use Types::TypeTiny qw(StringLike);
+
+use namespace::clean;
+
+=head1 VERSION
+
+Version v1.1.4
+
+=cut
+
+our $VERSION = version->declare("v1.1.4");
+
+=head1 DESCRIPTION
+
+Outside the box is a World of software,
+consisting of parts.
+
+B<Boxer::Part::Reclass::Node> represents a part of a <Boxer::World>,
+represented as a B<reclass> node or class.
+
+=head1 SEE ALSO
+
+L<Boxer>.
+
+=cut
+
+has id => (
+ is => 'ro',
+ isa => Str,
+);
+
+has classes => (
+ is => 'ro',
+ isa => Maybe [ ArrayRef [Str] ],
+);
+
+has doc => (
+ is => 'ro',
+ isa => HashRef,
+);
+
+has pkg => (
+ is => 'ro',
+ isa => ArrayRef [Str],
+);
+
+has pkg_auto => (
+ is => 'ro',
+ isa => ArrayRef [Str],
+);
+
+has pkg_avoid => (
+ is => 'ro',
+ isa => ArrayRef [Str],
+);
+
+has pkg_nonfree => (
+ is => 'ro',
+ isa => ArrayRef [Str],
+);
+
+has pkg_nonfree_auto => (
+ is => 'ro',
+ isa => ArrayRef [Str],
+);
+
+has bug => (
+ is => 'ro',
+ isa => ArrayRef [Str],
+);
+
+has tweak => (
+ is => 'ro',
+ isa => ArrayRef [Str],
+);
+
+has epoch => (
+ is => 'ro',
+ isa => Maybe [StringLike],
+);
+
+=head1 AUTHOR
+
+Jonas Smedegaard C<< <dr at jones.dk> >>.
+
+=cut
+
+our $AUTHORITY = 'cpan:JONASS';
+
+=head1 COPYRIGHT AND LICENCE
+
+Copyright © 2016 Jonas Smedegaard
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+=cut
+
+1;
diff --git a/lib/Boxer/Task/Classify.pm b/lib/Boxer/Task/Classify.pm
index e2e3e45..c6c46cf 100644
--- a/lib/Boxer/Task/Classify.pm
+++ b/lib/Boxer/Task/Classify.pm
@@ -15,6 +15,8 @@ use IPC::System::Simple;
use File::BaseDir qw(data_dirs);
use Capture::Tiny qw(capture_stdout);
use YAML::XS;
+use Boxer::World::Reclass;
+use Boxer::Part::Reclass;
use Moo;
use Types::Standard qw( Maybe Str Undef );
@@ -79,7 +81,7 @@ sub run
{
my $self = shift;
- Load(
+ my $data = Load(
scalar(
capture_stdout {
system(
@@ -95,6 +97,20 @@ sub run
}
)
);
+
+ my @parts;
+ for ( keys %{ $data->{nodes} } ) {
+ push @parts,
+ Boxer::Part::Reclass->new(
+ id => $_,
+ epoch => $self->suite,
+ %{ $data->{nodes}{$_}{parameters} }
+ );
+ }
+
+ return Boxer::World::Reclass->new(
+ parts => \@parts,
+ );
}
=head1 AUTHOR
diff --git a/lib/Boxer/Task/Serialize.pm b/lib/Boxer/Task/Serialize.pm
index 94c3076..144bfc9 100644
--- a/lib/Boxer/Task/Serialize.pm
+++ b/lib/Boxer/Task/Serialize.pm
@@ -13,14 +13,13 @@ use autodie;
use Carp qw<croak>;
use Path::Tiny;
-use Try::Tiny;
use Template::Tiny;
use File::ShareDir qw(dist_dir);
use Moo;
-use Types::Standard qw( Bool HashRef Str Undef );
+use Types::Standard qw( Bool Str Undef InstanceOf );
use Types::Path::Tiny qw( Dir File Path );
-use Boxer::Types qw( SkelDir Suite );
+use Boxer::Types qw( SkelDir );
extends 'Boxer::Task';
use namespace::clean;
@@ -41,9 +40,9 @@ sub BUILDARGS
return {%args};
}
-has data => (
+has world => (
is => 'ro',
- isa => HashRef,
+ isa => InstanceOf ['Boxer::World::Reclass'],
required => 1,
);
@@ -108,109 +107,17 @@ has nonfree => (
default => sub {0},
);
-has suite => (
- is => 'ro',
- isa => Suite,
- required => 1,
- coerce => 1,
- default => sub {'wheezy'},
-);
-
-my $pos = 1;
-my @section_order = qw(
- Administration
- Service
- Console
- Desktop
- Language
- Framework
- Task
- Hardware
-);
-my %section_order = map { $_ => $pos++ } @section_order;
-
sub run
{
my $self = shift;
- ( defined( $self->data->{'nodes'}{ $self->node } ) )
- or croak "Undefined node \"" . $self->node . "\".";
-
- my %params = %{ $self->data->{'nodes'}{ $self->node }{'parameters'} };
-
- my %desc;
-
- my @section_keys = sort {
- ( $section_order{$a} // 1000 ) <=> ( $section_order{$b} // 1000 )
- || $a cmp $b
- } keys %{ $params{doc} };
-
- foreach my $key (@section_keys) {
- my $headline = $params{doc}{$key}{headline}[0] || $key;
- if (( $params{pkg} and $params{doc}{$key}{pkg} )
- or ( $self->nonfree
- and $params{'pkg-nonfree'}
- and $params{doc}{$key}{'pkg-nonfree'} )
- )
- {
- push @{ $desc{pkg} }, "# $headline";
- if ( $params{pkg} ) {
- foreach ( @{ $params{doc}{$key}{pkg} } ) {
- push @{ $desc{pkg} }, "# * $_";
- }
- }
- if ( $self->nonfree and $params{'pkg-nonfree'} ) {
- foreach ( @{ $params{doc}{$key}{'pkg-nonfree'} } ) {
- push @{ $desc{pkg} }, "# * [non-free] $_";
- }
- }
- }
- if ( $params{tweak} and $params{doc}{$key}{tweak} ) {
- push @{ $desc{tweak} }, "# $headline";
- foreach ( @{ $params{doc}{$key}{tweak} } ) {
- push @{ $desc{tweak} }, "# * $_";
- }
- }
- }
- my $pkgdesc
- = defined( $desc{pkg} )
- ? join( "\n", @{ $desc{pkg} } )
- : '';
- my $tweakdesc
- = defined( $desc{tweak} )
- ? join( "\n", @{ $desc{tweak} } )
- : '';
- my @pkg = try { @{ $params{pkg} } }
- catch {
- $self->_logger->warning('No packages resolved');
- return ();
- };
- my @pkgauto = try { @{ $params{'pkg-auto'} } }
- catch {
- $self->_logger->warning('No package auto-markings resolved');
- return ();
- };
- my @pkgavoid = try { @{ $params{'pkg-avoid'} } }
- catch {
- $self->_logger->warning('No package avoidance resolved');
- return ();
- };
- my @tweak = try { @{ $params{tweak} } }
- catch {
- $self->_logger->warning('No tweaks resolved');
- return ();
- };
- if ( $self->nonfree ) {
- push @pkg, @{ $params{'pkg-nonfree'} if ( $params{'pkg-nonfree'} ) };
- push @pkgauto, @{ $params{'pkg-nonfree-auto'} }
- if ( $params{'pkg-nonfree-auto'} );
- }
- my $pkglist = join( ' ', sort @pkg );
+ my $world = $self->world->flatten( $self->node, $self->nonfree, );
+
+ my $pkglist = join( ' ', sort @{ $world->pkgs } );
$pkglist .= " \\\n ";
- $pkglist .= join( ' ', sort map { $_ . '-' } @pkgavoid );
- my $pkgautolist = join( ' ', sort @pkgauto );
- chomp(@tweak);
- my $tweaklist = join( ";\\\n ", @tweak );
+ $pkglist .= join( ' ', sort map { $_ . '-' } @{ $world->pkgs_avoid } );
+ my $pkgautolist = join( ' ', sort @{ $world->pkgs_auto } );
+ my $tweaklist = join( ";\\\n ", @{ $world->tweaks } );
$self->outdir->mkpath;
@@ -220,10 +127,10 @@ sub run
my %vars = (
node => $self->node,
- suite => $self->suite,
- pkgdesc => $pkgdesc,
+ suite => $world->epoch,
+ pkgdesc => $world->pkgdesc,
pkglist => $pkglist,
- tweakdesc => $tweakdesc,
+ tweakdesc => $world->tweakdesc,
tweaklist => $tweaklist,
pkgautolist => $pkgautolist,
);
diff --git a/lib/Boxer/World.pm b/lib/Boxer/World.pm
new file mode 100644
index 0000000..bec9707
--- /dev/null
+++ b/lib/Boxer/World.pm
@@ -0,0 +1,73 @@
+package Boxer::World;
+
+=encoding UTF-8
+
+=head1 NAME
+
+Boxer::World - set of software available to install
+
+=cut
+
+use v5.14;
+use utf8;
+use strictures 2;
+use version;
+use Role::Commons -all;
+use autodie;
+
+use Moo;
+use Types::Standard qw(ArrayRef InstanceOf);
+
+use namespace::clean;
+
+=head1 VERSION
+
+Version v1.1.4
+
+=cut
+
+our $VERSION = version->declare("v1.1.4");
+
+=head1 DESCRIPTION
+
+Outside the box is a world of software.
+
+B<Boxer::World> is a class describing a collection of software
+available for installation into (or as) an operating system.
+
+=head1 SEE ALSO
+
+L<Boxer>.
+
+=cut
+
+has parts => (
+ is => 'ro',
+ isa => ArrayRef [ InstanceOf ['Boxer::Part'] ],
+ required => 1,
+);
+
+=head1 AUTHOR
+
+Jonas Smedegaard C<< <dr at jones.dk> >>.
+
+=cut
+
+our $AUTHORITY = 'cpan:JONASS';
+
+=head1 COPYRIGHT AND LICENCE
+
+Copyright © 2013-2016 Jonas Smedegaard
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+=cut
+
+1;
diff --git a/lib/Boxer/World/Reclass.pm b/lib/Boxer/World/Reclass.pm
new file mode 100644
index 0000000..2cb1643
--- /dev/null
+++ b/lib/Boxer/World/Reclass.pm
@@ -0,0 +1,195 @@
+package Boxer::World::Reclass;
+
+=encoding UTF-8
+
+=head1 NAME
+
+Boxer::World::Reclass - software as serialized by reclass
+
+=cut
+
+use v5.14;
+use utf8;
+use strictures 2;
+use version;
+use Role::Commons -all;
+use autodie;
+use Carp qw<croak>;
+
+use Try::Tiny;
+
+use Moo;
+extends 'Boxer::World';
+use Types::Standard qw(ArrayRef InstanceOf);
+use Boxer::World::Flat;
+with qw(MooX::Role::Logger);
+
+use namespace::clean;
+
+=head1 VERSION
+
+Version v1.1.4
+
+=cut
+
+our $VERSION = version->declare("v1.1.4");
+
+=head1 DESCRIPTION
+
+Outside the box is a world of software.
+
+B<Boxer::World::Reclass> is a class describing a collection of software
+available for installation into (or as) an operating system.
+
+=head1 SEE ALSO
+
+L<Boxer>.
+
+=cut
+
+has parts => (
+ is => 'ro',
+ isa => ArrayRef [ InstanceOf ['Boxer::Part::Reclass'] ],
+ required => 1,
+);
+
+sub get_node_by_id
+{
+ my ( $self, $id ) = @_;
+
+ foreach ( @{ $self->parts } ) {
+ if ( $_->id eq $id ) {
+ return $_;
+ }
+ }
+ croak "This world contains no node identified as \"" . $id . "\".";
+}
+
+my $pos = 1;
+my @section_order = qw(
+ Administration
+ Service
+ Console
+ Desktop
+ Language
+ Framework
+ Task
+ Hardware
+);
+my %section_order = map { $_ => $pos++ } @section_order;
+
+sub flatten
+{
+ my ( $self, $node_id, $nonfree ) = @_;
+
+ my $node = $self->get_node_by_id($node_id);
+
+ ( $node->epoch )
+ or croak "Undefined epoch for node \"" . $self->node . "\".";
+
+ my %desc;
+
+ my @section_keys = sort {
+ ( $section_order{$a} // 1000 ) <=> ( $section_order{$b} // 1000 )
+ || $a cmp $b
+ } keys %{ $node->{doc} };
+
+ foreach my $key (@section_keys) {
+ my $headline = $node->{doc}{$key}{headline}[0] || $key;
+ if (( $node->{pkg} and $node->{doc}{$key}{pkg} )
+ or ( $nonfree
+ and $node->{'pkg-nonfree'}
+ and $node->{doc}{$key}{'pkg-nonfree'} )
+ )
+ {
+ push @{ $desc{pkg} }, "# $headline";
+ if ( $node->{pkg} ) {
+ foreach ( @{ $node->{doc}{$key}{pkg} } ) {
+ push @{ $desc{pkg} }, "# * $_";
+ }
+ }
+ if ( $nonfree and $node->{'pkg-nonfree'} ) {
+ foreach ( @{ $node->{doc}{$key}{'pkg-nonfree'} } ) {
+ push @{ $desc{pkg} }, "# * [non-free] $_";
+ }
+ }
+ }
+ if ( $node->{tweak} and $node->{doc}{$key}{tweak} ) {
+ push @{ $desc{tweak} }, "# $headline";
+ foreach ( @{ $node->{doc}{$key}{tweak} } ) {
+ push @{ $desc{tweak} }, "# * $_";
+ }
+ }
+ }
+ my $pkgdesc
+ = defined( $desc{pkg} )
+ ? join( "\n", @{ $desc{pkg} } )
+ : '';
+ my $tweakdesc
+ = defined( $desc{tweak} )
+ ? join( "\n", @{ $desc{tweak} } )
+ : '';
+ my @pkg = try { @{ $node->{pkg} } }
+ catch {
+ $self->_logger->warning('No packages resolved');
+ return ();
+ };
+ my @pkgauto = try { @{ $node->{'pkg-auto'} } }
+ catch {
+ $self->_logger->warning('No package auto-markings resolved');
+ return ();
+ };
+ my @pkgavoid = try { @{ $node->{'pkg-avoid'} } }
+ catch {
+ $self->_logger->warning('No package avoidance resolved');
+ return ();
+ };
+ my @tweak = try { @{ $node->{tweak} } }
+ catch {
+ $self->_logger->warning('No tweaks resolved');
+ return ();
+ };
+ if ($nonfree) {
+ push @pkg, @{ $node->{'pkg-nonfree'} if ( $node->{'pkg-nonfree'} ) };
+ push @pkgauto, @{ $node->{'pkg-nonfree-auto'} }
+ if ( $node->{'pkg-nonfree-auto'} );
+ }
+ chomp(@tweak);
+
+ return Boxer::World::Flat->new(
+ node => $node_id,
+ epoch => $node->epoch,
+ pkgs => \@pkg,
+ pkgs_auto => \@pkgauto,
+ pkgs_avoid => \@pkgavoid,
+ tweaks => \@tweak,
+ pkgdesc => $pkgdesc,
+ tweakdesc => $tweakdesc,
+ nonfree => $nonfree, # TODO: unset if none resolved
+ );
+}
+
+=head1 AUTHOR
+
+Jonas Smedegaard C<< <dr at jones.dk> >>.
+
+=cut
+
+our $AUTHORITY = 'cpan:JONASS';
+
+=head1 COPYRIGHT AND LICENCE
+
+Copyright © 2013-2016 Jonas Smedegaard
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+=cut
+
+1;
diff --git a/t/world.t b/t/world.t
new file mode 100644
index 0000000..2b029dc
--- /dev/null
+++ b/t/world.t
@@ -0,0 +1,62 @@
+#!/usr/bin/perl
+
+use v5.14;
+use utf8;
+use strictures 2;
+
+#use Test::More tests => 6;
+use Test::More;
+use Test::Exception;
+use Test::File::Contents;
+use Path::Tiny;
+
+use_ok('Boxer::Part::Reclass');
+use_ok('Boxer::World::Reclass');
+use_ok('Boxer::Task::Classify');
+use_ok('Boxer::Task::Serialize');
+
+my $from_reclass = new_ok(
+ 'Boxer::Task::Classify' => [
+ datadir => path('examples'),
+ ]
+);
+
+my $world = $from_reclass->run;
+my $outdir = Path::Tiny->tempdir;
+note("Temporary output directory is $outdir");
+
+my $to_compositions = new_ok(
+ 'Boxer::Task::Serialize' => [
+ world => $world,
+ skeldir => path('share')->child('skel'),
+ outdir => $outdir,
+ node => 'lxp5',
+ ]
+);
+$to_compositions->run;
+file_contents_like $outdir->child('preseed.cfg'),
+ qr/pkgsel\/include string acpi-support/,
+ 'content of "preseed.cfg" seems ok';
+file_contents_like $outdir->child('script.sh'),
+ qr/apt-get install acpi-support/,
+ 'content of "script.sh" seems ok';
+
+my $from_root = new_ok( 'Boxer::Task::Classify' => [ datadir => path('.') ] );
+
+throws_ok(
+ sub {
+ $from_root->run;
+ },
+ qr/Must be an existing directory containing boxer classes/,
+ 'Died as expected on existing but wrong datadir'
+);
+
+throws_ok(
+ sub {
+ Boxer::Task::Classify->new( datadir => path('nowhere') );
+ },
+ qr/Directory 'nowhere' does not exist/,
+ 'Died as expected on non-exising datadir'
+);
+
+done_testing();
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/boxer.git
More information about the Pkg-perl-cvs-commits
mailing list