SL/Helper/Csv/Dispatcher.pm

   1 package SL::Helper::Csv::Dispatcher;
   2
   3 use strict;
   4
   5 use Data::Dumper;
   6 use Carp;
   7 use Scalar::Util qw(weaken);
   8 use List::MoreUtils qw(all pairwise);
   9 use Rose::Object::MakeMethods::Generic scalar => [ qw(
  10   _specs _row_class _row_spec _errors
  11 ) ];
  12
  13 use SL::Helper::Csv::Error;
  14
  15 sub new {
  16   my ($class, $parent) = @_;
  17   my $self = bless { }, $class;
  18
  19   weaken($self->{_csv} = $parent);
  20   $self->_errors([]);
  21
  22   return $self;
  23 }
  24
  25 sub dispatch {
  26   my ($self, $line) = @_;
  27
  28   my $class = $self->_class_by_line($line);
  29   croak 'no class given' unless $class;
  30
  31   eval "require " . $class;
  32   my $obj = $class->new;
  33
  34   my $specs = $self->_specs_by_line($line);
  35   for my $spec (@{ $specs }) {
  36     $self->apply($obj, $spec, $line->{$spec->{key}});
  37   }
  38
  39   return $obj;
  40 }
  41
  42 sub _class_by_line {
  43   my ($self, $line) = @_;
  44
  45   # initialize lookup hash if not already done
  46   if ($self->_csv->is_multiplexed && ! defined $self->_row_class ) {
  47     $self->_row_class({ map { $_->{row_ident} => $_->{class} } @{ $self->_csv->profile } });
  48   }
  49
  50   if ($self->_csv->is_multiplexed) {
  51     return $self->_row_class->{$line->{datatype}};
  52   } else {
  53     return $self->_csv->profile->[0]->{class};
  54   }
  55 }
  56
  57 sub _specs_by_line {
  58   my ($self, $line) = @_;
  59
  60   # initialize lookup hash if not already done
  61   if ($self->_csv->is_multiplexed && ! defined $self->_row_spec ) {
  62     $self->_row_spec({ pairwise { no warnings 'once'; $a->{row_ident} => $b } @{ $self->_csv->profile }, @{ $self->_specs } });
  63   }
  64
  65   if ($self->_csv->is_multiplexed) {
  66     return $self->_row_spec->{$line->{datatype}};
  67   } else {
  68     return $self->_specs->[0];
  69   }
  70 }
  71
  72
  73 sub apply {
  74   my ($self, $obj, $spec, $value) = @_;
  75   return unless $value;
  76
  77   for my $step (@{ $spec->{steps} }) {
  78     my ($acc, $class, $index) = @$step;
  79     if ($class) {
  80
  81       # autovifify
  82       if (defined $index) {
  83         if (! $obj->$acc || !$obj->$acc->[$index]) {
  84           my @objects = $obj->$acc;
  85           $obj->$acc(@objects, map { $class->new } 0 .. $index - @objects);
  86         }
  87         $obj = $obj->$acc->[$index];
  88       } else {
  89         if (! $obj->$acc) {
  90           $obj->$acc($class->new);
  91         }
  92         $obj = $obj->$acc;
  93       }
  94
  95     } else {
  96       $obj->$acc($value);
  97     }
  98   }
  99 }
 100
 101 sub is_known {
 102   my ($self, $col, $row) = @_;
 103   return grep { $col eq $_->{key} } @{ $self->_specs->[$row // 0] };
 104 }
 105
 106 sub parse_profile {
 107   my ($self, %params) = @_;
 108
 109   my @specs;
 110
 111   my $csv_profile = $self->_csv->profile;
 112   my $h_aref = ($self->_csv->is_multiplexed)? $self->_csv->header : [ $self->_csv->header ];
 113   my $i = 0;
 114   foreach my $header (@{ $h_aref }) {
 115     my $spec = $self->_parse_profile(profile => $csv_profile->[$i]->{profile},
 116                                      mapping => $csv_profile->[$i]->{mapping},
 117                                      class   => $csv_profile->[$i]->{class},
 118                                      header  => $header);
 119     push @specs, $spec;
 120     $i++;
 121   }
 122
 123   $self->_specs(\@specs);
 124
 125   $self->_csv->_push_error($self->errors);
 126
 127   return ! $self->errors;
 128 }
 129
 130 sub _parse_profile {
 131   my ($self, %params) = @_;
 132
 133   my $profile = $params{profile} // {};
 134   my $class   = $params{class};
 135   my $header  = $params{header};
 136   my $mapping = $params{mapping};
 137
 138   my @specs;
 139
 140   for my $col (@$header) {
 141     next unless $col;
 142     if (exists $mapping->{$col} && $profile->{$mapping->{$col}}) {
 143       push @specs, $self->make_spec($col, $profile->{$mapping->{$col}}, $class);
 144     } elsif (exists $mapping->{$col} && !%{ $profile }) {
 145       push @specs, $self->make_spec($col, $mapping->{$col}, $class);
 146     } elsif (exists $profile->{$col}) {
 147       push @specs, $self->make_spec($col, $profile->{$col}, $class);
 148     } else {
 149       if ($self->_csv->strict_profile) {
 150         $self->unknown_column($col, undef);
 151       } else {
 152         push @specs, $self->make_spec($col, $col, $class);
 153       }
 154     }
 155   }
 156
 157   return \@specs;
 158 }
 159
 160 sub make_spec {
 161   my ($self, $col, $path, $cur_class) = @_;
 162
 163   my $spec = { key => $col, path => $path, steps => [] };
 164
 165   return unless $path;
 166
 167   return unless $cur_class;
 168
 169   for my $step_index ( split /\.(?!\d)/, $path ) {
 170     my ($step, $index) = split /\./, $step_index;
 171     if ($cur_class->can($step)) {
 172       if (my $rel = $cur_class->meta->relationship($step)) { #a
 173         if ($index && ! $rel->isa('Rose::DB::Object::Metadata::Relationship::OneToMany')) {
 174           $self->_push_error([
 175             $path,
 176             undef,
 177             "Profile path error. Indexed relationship is not OneToMany around here: '$step_index'",
 178             undef,
 179             0,
 180           ]);
 181           return;
 182         } else {
 183           my $next_class = $cur_class->meta->relationship($step)->class;
 184           push @{ $spec->{steps} }, [ $step, $next_class, $index ];
 185           $cur_class = $next_class;
 186           eval "require $cur_class; 1" or die "could not load class '$cur_class'";
 187         }
 188       } else { # simple dispatch
 189         push @{ $spec->{steps} }, [ $step ];
 190         last;
 191       }
 192     } else {
 193       $self->unknown_column($col, $path);
 194     }
 195   }
 196
 197   return $spec;
 198 }
 199
 200 sub unknown_column {
 201   my ($self, $col, $path) = @_;
 202   return if $self->_csv->ignore_unknown_columns;
 203
 204   $self->_push_error([
 205     $col,
 206     undef,
 207     "header field '$col' is not recognized",
 208     undef,
 209     0,
 210   ]);
 211 }
 212
 213 sub _csv {
 214   $_[0]->{_csv};
 215 }
 216
 217 sub errors {
 218   @{ $_[0]->_errors }
 219 }
 220
 221 sub _push_error {
 222   my ($self, @errors) = @_;
 223   my @new_errors = ($self->errors, map { SL::Helper::Csv::Error->new(@$_) } @errors);
 224   $self->_errors(\@new_errors);
 225 }
 226
 227 1;