perl/t/version_input.pm

   1 package version_input;
   2 use strict;
   3 use warnings;
   4
   5 use feature 'switch';
   6 use Scalar::Util 'reftype';
   7
   8 =head version_input
   9
  10 This file reads the c<version-input.yml> file that resides in the
  11 same directory, and filters the data for test files.
  12
  13 =cut
  14
  15 require Exporter;
  16 our @EXPORT = 'load';
  17
  18 use Modern::Perl;
  19 use Data::Dump 'dump';
  20
  21 use lib qw'. ./t';
  22 eval 'use version_input;' unless $INC{''.__PACKAGE__};
  23
  24 our %test;
  25 {
  26   # $filename is in the same directory as this package
  27   my $package_file = __PACKAGE__.'.pm';
  28   my $filename;
  29   ($filename = $INC{$package_file}) =~ s/$package_file/version-input.yml/;
  30
  31   require YAML::XS;
  32   my $str;
  33   {
  34     local $/ = undef;
  35     open my $file, '<', $filename;
  36     $str = <$file>;
  37     close $file;
  38   }
  39   %test = %{YAML::XS::LoadFile $filename};
  40 }
  41
  42 # load add => {key=>'default'}, map=>{}, filter=>[]
  43 sub load{
  44   local( $_, %_ );
  45   #my($add,$filter,$map,$all);
  46   my( @filter, %map, $all );
  47
  48   my %return;
  49   while( my $next = shift ){
  50     given( $next ){
  51       when( 'map'    ){
  52         my $hashref = shift;
  53         my @keys = keys %$hashref;
  54         @map{@keys} = @$hashref{@keys};
  55       }
  56       when( 'filter' ){ push @filter, @{shift @_} }
  57       when( 'all'    ){ $all = 1; last }
  58       default{ die }
  59     }
  60   }
  61
  62   for my $version(keys %test){
  63     my %details = %{$test{$version}};
  64
  65
  66     if($all){
  67       $return{$version} = {%details};
  68     }else{
  69       my $current = $return{$version} = {};
  70       $details{version} = $version;
  71
  72       # filter
  73       #
  74       # any element listed here will be added to the output
  75       for my $add (@filter){
  76         if('+' eq substr $add, 0, 1){
  77           # forced to exist
  78           $add = substr $add, 1;
  79           $current->{$add} = $details{$add}
  80         }else{
  81           $current->{$add} = $details{$add} if exists $details{$add};
  82         }
  83       }
  84
  85       # map
  86       for my $id( keys %map ){
  87         my $ref = $map{$id};
  88
  89         given( reftype $ref ){
  90           when(undef){ $current->{$id} = $details{$ref} }
  91           when('CODE'){
  92             %_ = %details;
  93             my $_ = $details{$id};
  94
  95             my $return = $ref->(
  96               $id,
  97               $details{$id},
  98               $version,
  99               {%details}
 100             );
 101
 102             $current->{$id} = $return;
 103           }
 104           default{ die }
 105         }
 106       }
 107     }
 108   }
 109
 110
 111   return %return if wantarray;
 112   return \%return;
 113 }
 114 1;