perl/t/version_input.pm

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