File Coverage

lib/Gentoo/Overlay/Category.pm
Criterion Covered Total %
statement 69 88 78.4
branch 7 12 58.3
condition n/a
subroutine 18 22 81.8
pod 4 4 100.0
total 98 126 77.7


line stmt bran cond sub pod time code
1 5     5   567 use 5.006;
  5         12  
  5         160  
2 5     5   18 use strict;
  5         6  
  5         131  
3 5     5   21 use warnings;
  5         10  
  5         306  
4              
5             package Gentoo::Overlay::Category;
6              
7             our $VERSION = '2.001001';
8              
9             # ABSTRACT: A singular category in a repository;
10              
11             our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
12              
13 5     5   428 use Moo 1.006000 qw( has );
  5         11126  
  5         27  
14 5     5   2405 use MooseX::Has::Sugar qw( ro required coerce lazy lazy_build );
  5         462  
  5         40  
15 5     5   1081 use Types::Standard qw( HashRef Str );
  5         48555  
  5         41  
16 5     5   3564 use Types::Path::Tiny qw( File Dir Path );
  5         25734  
  5         27  
17 5     5   2494 use MooX::ClassAttribute qw( class_has );
  5         10659  
  5         28  
18 5     5   737 use MooX::HandlesVia;
  5         564  
  5         30  
19 5     5   1788 use Gentoo::Overlay::Types qw( Gentoo__Overlay_CategoryName Gentoo__Overlay_Package Gentoo__Overlay_Overlay );
  5         12  
  5         51  
20 5     5   4334 use Gentoo::Overlay::Exceptions qw( exception );
  5         16  
  5         52  
21 5     5   529 use namespace::clean -except => 'meta';
  5         8  
  5         45  
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             has name => ( isa => Gentoo__Overlay_CategoryName, required, ro );
54             has overlay => ( isa => Gentoo__Overlay_Overlay, required, ro, coerce );
55             has path => ( lazy, ro,
56             isa => Path,
57             default => sub {
58             my ($self) = shift;
59             return $self->overlay->default_path( category => $self->name );
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             has _packages => (
115             isa => HashRef [Gentoo__Overlay_Package],
116             lazy,
117             builder => 1,
118             ro,
119             handles_via => 'Hash',
120             handles => {
121             _has_package => exists =>,
122             package_names => keys =>,
123             packages => elements =>,
124             get_package => get =>,
125             },
126             );
127              
128              
129              
130              
131              
132              
133              
134              
135              
136             sub _build__packages {
137 4     4   1805 my ($self) = shift;
138 4         830 require Gentoo::Overlay::Package;
139              
140 4         89 my $it = $self->path->iterator();
141 4         128 my %out;
142 4         11 while ( defined( my $entry = $it->() ) ) {
143 5         787 my $package = $entry->basename;
144 5 50       154 next if Gentoo::Overlay::Package->is_blacklisted($package);
145 5         124 my $p = Gentoo::Overlay::Package->new(
146             name => $package,
147             category => $self,
148             );
149 5 100       181 next unless $p->exists;
150 1         4 $out{$package} = $p;
151             }
152 4         383 return \%out;
153             }
154              
155              
156              
157              
158              
159              
160              
161              
162              
163              
164              
165              
166              
167              
168              
169              
170              
171              
172              
173              
174              
175              
176              
177              
178              
179              
180              
181              
182             class_has _scan_blacklist => (
183             isa => HashRef [Str],
184             ro,
185             lazy,
186             default => sub {
187             return { map { $_ => 1 } qw( metadata profiles distfiles eclass licenses packages scripts . .. ) };
188             },
189             );
190              
191             sub _scan_blacklisted {
192 3     3   3 my ( $self, $what ) = @_;
193 3         39 return exists $self->_scan_blacklist->{$what};
194             }
195              
196              
197              
198              
199              
200              
201              
202              
203              
204             ## no critic ( ProhibitBuiltinHomonyms )
205             sub exists {
206 12     12 1 17 my $self = shift;
207 12 100       171 return if not -e $self->path;
208 11 50       1178 return if not -d $self->path;
209 11         273 return 1;
210             }
211              
212              
213              
214              
215              
216              
217              
218              
219              
220              
221              
222             sub is_blacklisted {
223 3     3 1 5 my ( $self, $name ) = @_;
224 3 50       6 if ( not defined $name ) {
225 0         0 $name = $self->name;
226             }
227 3         7 return $self->_scan_blacklisted($name);
228             }
229              
230              
231              
232              
233              
234              
235              
236              
237              
238             sub pretty_name {
239 0     0 1 0 my $self = shift;
240 0         0 return $self->name . '/::' . $self->overlay->name;
241             }
242              
243              
244              
245              
246              
247              
248              
249              
250              
251              
252              
253              
254              
255              
256              
257              
258              
259              
260              
261              
262              
263              
264              
265              
266              
267              
268              
269              
270              
271              
272              
273              
274              
275              
276              
277              
278              
279              
280              
281              
282              
283              
284              
285             sub iterate {
286 0     0 1 0 my ( $self, $what, $callback ) = @_; ## no critic (Variables::ProhibitUnusedVarsStricter)
287 0         0 my %method_map = (
288             packages => _iterate_packages =>,
289             ebuilds => _iterate_ebuilds =>,
290             );
291 0 0       0 if ( exists $method_map{$what} ) {
292 0         0 goto $self->can( $method_map{$what} );
293             }
294 0         0 return exception(
295             ident => 'bad iteration method',
296             message => 'The iteration method %{what_method}s is not a known way to iterate.',
297             payload => { what_method => $what, },
298             );
299             }
300              
301              
302              
303              
304              
305              
306              
307              
308              
309              
310              
311             # packages = { /packages }
312             sub _iterate_packages {
313 4     4   8 my ( $self, undef, $callback ) = @_;
314 4         54 my %packages = $self->packages();
315 4         230 my $num_packages = scalar keys %packages;
316 4         10 my $last_package = $num_packages - 1;
317 4         5 my $offset = 0;
318 4         15 for my $pname ( sort keys %packages ) {
319 1         1 local $_ = $packages{$pname};
320 1         6 $self->$callback(
321             {
322             package_name => $pname,
323             package => $packages{$pname},
324             num_packages => $num_packages,
325             last_package => $last_package,
326             package_num => $offset,
327             }
328             );
329 1         5 $offset++;
330             }
331 4         33 return;
332              
333             }
334              
335              
336              
337              
338              
339              
340              
341              
342              
343              
344              
345             # ebuilds = { /packages/ebuilds }
346             sub _iterate_ebuilds {
347 0     0     my ( $self, undef, $callback ) = @_;
348             my $real_callback = sub {
349              
350 0     0     my (%pconfig) = %{ $_[1] };
  0            
351             my $inner_callback = sub {
352 0           my %econfig = %{ $_[1] };
  0            
353 0           $self->$callback( { ( %pconfig, %econfig ) } );
354 0           };
355 0           $pconfig{package}->_iterate_ebuilds( 'ebuilds' => $inner_callback );
356 0           };
357 0           $self->_iterate_packages( packages => $real_callback );
358 0           return;
359              
360             }
361 5     5   5347 no Moo;
  5         8  
  5         24  
362             1;
363              
364             __END__
365              
366             =pod
367              
368             =encoding UTF-8
369              
370             =head1 NAME
371              
372             Gentoo::Overlay::Category - A singular category in a repository;
373              
374             =head1 VERSION
375              
376             version 2.001001
377              
378             =head1 SYNOPSIS
379              
380             Still limited functionality, more to come.
381              
382             my $category = ::Overlay::Category->new(
383             name => 'dev-perl',
384             overlay => '/usr/portage' ,
385             );
386              
387             my $category = ::Overlay::Category->new(
388             name => 'dev-perl',
389             overlay => $overlay_object ,
390             );
391              
392             $category->exists() # is the category there, is it a directory?
393              
394             $category->pretty_name() # dev-perl/::gentoo
395              
396             $category->path() # /usr/portage/dev-perl
397              
398             ::Overlay::Category->is_blacklisted('..') # is '..' a blacklisted category
399              
400             =head1 METHODS
401              
402             =head2 exists
403              
404             Does the category exist, and is it a directory?
405              
406             $category->exists();
407              
408             =head2 is_blacklisted
409              
410             Does the category name appear on a blacklist meaning auto-scan should ignore this?
411              
412             ::Category->is_blacklisted('..') # true
413              
414             ::Category->is_blacklisted('metadata') # true
415              
416             =head2 pretty_name
417              
418             A pretty form of the name.
419              
420             $category->pretty_name # dev-perl/::gentoo
421              
422             =head2 iterate
423              
424             $overlay->iterate( $what, sub {
425             my ( $context_information ) = shift;
426              
427             } );
428              
429             The iterate method provides a handy way to do walking across the whole tree stopping at each of a given type.
430              
431             =over 4
432              
433             =item * C<$what = 'packages'>
434              
435             $overlay->iterate( packages => sub {
436             my ( $self, $c ) = shift;
437             # $c->{package_name} # String
438             # $c->{package} # Package Object
439             # $c->{num_packages} # How many packages are there to iterate
440             # $c->{last_package} # Index ID of the last package.
441             # $c->{package_num} # Index ID of the current package.
442             } );
443              
444             =item * C<$what = 'ebuilds'>
445              
446             $overlay->iterate( ebuilds => sub {
447             my ( $self, $c ) = shift;
448             # $c->{package_name} # String
449             # $c->{package} # Package Object
450             # $c->{num_packages} # How many packages are there to iterate
451             # $c->{last_package} # Index ID of the last package.
452             # $c->{package_num} # Index ID of the current package.
453              
454             # $c->{ebuild_name} # String
455             # See ::Ebuild for the rest of the fields provided by the ebuild Iterator.
456             # Very similar though.
457             } );
458              
459             =back
460              
461             =head1 ATTRIBUTES
462              
463             =head2 name
464              
465             The classes short name
466              
467             isa => Gentoo__Overlay_CategoryName, required, ro
468              
469             L<< C<CategoryName>|Gentoo::Overlay::Types/Gentoo__Overlay_CategoryName >>
470              
471             =head2 overlay
472              
473             The overlay it is in.
474              
475             isa => Gentoo__Overlay_Overlay, required, coerce
476              
477             L<Gentoo::Overlay::Types/Gentoo__Overlay_Overlay>
478              
479             =head2 path
480              
481             The full path to the category
482              
483             isa => Dir, lazy, ro
484              
485             L<MooseX::Types::Path::Tiny/Dir>
486              
487             =head1 ATTRIBUTE ACCESSORS
488              
489             =head2 package_names
490              
491             for( $category->package_names ){
492             print $_;
493             }
494              
495             L</_packages>
496              
497             =head2 packages
498              
499             my %packages = $category->packages;
500              
501             L</_packages>
502              
503             =head2 get_package
504              
505             my $package = $category->get_package('Moose');
506              
507             L</_packages>
508              
509             =head1 PRIVATE ATTRIBUTES
510              
511             =head2 _packages
512              
513             isa => HashRef[ Gentoo__Overlay_Package ], lazy_build, ro
514              
515             accessors => _has_package , package_names,
516             packages, get_package
517              
518             L</_has_package>
519              
520             L</package_names>
521              
522             L</packages>
523              
524             L</get_package>
525              
526             =head1 PRIVATE ATTRIBUTE ACCESSORS
527              
528             =head2 _has_package
529              
530             $category->_has_package('Moose');
531              
532             L</_packages>
533              
534             =head1 PRIVATE CLASS ATTRIBUTES
535              
536             =head2 _scan_blacklist
537              
538             Class-Wide list of blacklisted directory names.
539              
540             isa => HashRef[ Str ], ro, lazy
541              
542             accessors => _scan_blacklisted
543              
544             L</_scan_blacklisted>
545              
546             L<< C<MooseX::Types::Moose>|MooseX::Types::Moose >>
547              
548             =head1 PRIVATE CLASS ATTRIBUTE ACCESSORS
549              
550             =head2 _scan_blacklisted
551              
552             is C<$arg> blacklisted in the Class Wide Blacklist?
553              
554             ::Category->_scan_blacklisted( $arg )
555             ->
556             exists ::Category->_scan_blacklist->{$arg}
557              
558             L</_scan_blacklist>
559              
560             =head1 PRIVATE METHODS
561              
562             =head2 _build__packages
563              
564             Generates the package Hash-Table, by scanning the category directory.
565              
566             L</_packages>
567              
568             =head2 _iterate_packages
569              
570             $object->_iterate_packages( ignored_value => sub { } );
571              
572             Handles dispatch call for
573              
574             $object->iterate( packages => sub { } );
575              
576             =head2 _iterate_ebuilds
577              
578             $object->_iterate_ebuilds( ignored_value => sub { } );
579              
580             Handles dispatch call for
581              
582             $object->iterate( ebuilds => sub { } );
583              
584             =head1 AUTHOR
585              
586             Kent Fredric <kentnl@cpan.org>
587              
588             =head1 COPYRIGHT AND LICENSE
589              
590             This software is copyright (c) 2014 by Kent Fredric <kentnl@cpan.org>.
591              
592             This is free software; you can redistribute it and/or modify it under
593             the same terms as the Perl 5 programming language system itself.
594              
595             =cut