view release on metacpan or  search on metacpan

lib-not_ready/App/csv_join.pm  view on Meta::CPAN

        # build lookup table w/ C-style loop for efficiency on large files
        my %lookup_table; # key = joined lookup fields, val = source row idx
        for(my $row_idx=0; $row_idx<=$#{$r->{source_data_rows}}; $row_idx++) {
            my($row, $key1, $key2);
            $row = $r->{source_data_rows}[$row_idx];
            $key1 = join $keySep, map {
                my $field = $r->{lookup_fields}[$_][1];
                my $field_idx = $r->{source_fields_idx}->{$field};
                my $val = defined $field_idx ? $row->[$field_idx] : "";
                $val = lc $val if $ci;
                $val;
            } 0..$#{ $r->{lookup_fields} };
            if( $fuzzy ){
                $key2 = join $keySep, map {
                    my $field = $r->{fuzzy}[$_][1];
                    my $field_idx = $r->{source_fields_idx}{$field};
                    my $val = defined $field_idx ? $row->[$field_idx] : '';
                    $val = lc $val if $ci;
                } 0..$#{ $r->{fuzzy} };
            } else {
                $key2 = 'STATIC';
            }
            #JDP: Split key greatly improves fuzzy match performance by binning data,
            #     thereby reducing pool of values to check with any given regexp
            $lookup_table{$key1}->{$key2} //= $row_idx;
            #warn "Prepped key1($key1)\tkey2($key2) for $row_idx\n"# unless $row_idx %20;
        }
        #use DD; dd { lookup_fields=>$r->{lookup_fields}, fill_fields=>$r->{fill_fields}, lookup_table=>\%lookup_table };

        # fill target csv
        my $rows_filled = 0;

        for(my $i=0; $i<=$#{ $r->{target_data_rows} }; $i++){
            my $row = $r->{target_data_rows}->[$i];
            my($key1, $key2);

            $key1 = join $keySep, map {
                my $field = $r->{lookup_fields}[$_][0];
                my $field_idx = $r->{target_fields_idx}{$field};
                my $val = defined $field_idx ? $row->[$field_idx] : "";
                $val = lc $val if $ci;
                $val;
            } 0..$#{ $r->{lookup_fields} };
            if( $fuzzy ){
                $key2 = join '.*?'.$keySep, map {
                    my $field = $r->{fuzzy}[$_][0];
                    my $field_idx = $r->{target_fields_idx}{$field};
                    my $val = defined $field_idx ? $row->[$field_idx] : '';
                    $val = lc $val if $ci;
                    #JDP: Wrapping is superfluous if single fuzzy key,
                    #     as is explicit match anything at beginning and ending of key
                    #     post-wrap is handled in join to reduce testing of $_
                    my $prewrap  = $_==0 ? '' : '.*?';
                    $fuzzy >1 ? $prewrap . quotemeta($val) : quotemeta($val);
                } 0..$#{ $r->{fuzzy} };
            } else {
                $key2 = 'STATIC';
            }

            #say "D:looking up '$key1'\t'$key2' ...";
            my(@row_idx, $K1LUT);
            #JDP: explore MCE for performance boost?
            if( defined($K1LUT = $lookup_table{$key1}) ){
                #warn "Matched $key1\n";
                unless( $fuzzy ){
                    @row_idx = ($K1LUT->{STATIC}) }
                else{
                    $key2 = qr/$key2/;
                    foreach my $TK2 ( keys %{$K1LUT} ){
                        push(@row_idx, $K1LUT->{$TK2}) if $TK2 =~ /$key2/;
                        #warn "$key1: Testing $TK2 =~ /$key2/ (@{[ $TK2 =~ /$key2/ ]})\t$K1LUT->{$TK2}\n" if $key1 == 734;

                        #JDP: Short-circuit unless inner join requested
                        last if scalar @row_idx && !$inner;
                    }
                }

                #say "  D:found";
                for(my $j=0; $j<=$#row_idx; $j++ ){
                    my $row = $row;
                    my $fields_filled;
                    my $row_idx = $row_idx[$j];
                    my $source_row = $r->{source_data_rows}[$row_idx];

                    $row = Storable::dclone($r->{target_data_rows}->[$i]) if $fuzzy && $j && $inner;

                    for my $field (keys %{$r->{fill_fields}}) {
                        my $target_field_idx = $r->{target_fields_idx}{$field};
                        #JDP: Why is this being checked every time? $r->{target_fields_idx} does not change.
                        #     There isn't even a clear way for its values to be undef
                        #next unless defined $target_field_idx;

                        my $source_field_idx = $r->{source_fields_idx}{ $r->{fill_fields}{$field} };
                        #JDP: Why is this being checked every time? $r->{source_fields_idx} does not change
                        #     There isn't even a clear way for its values to be undef
                        #next unless defined $source_field_idx;

                        $row->[$target_field_idx] = $source_row->[$source_field_idx];
                        $fields_filled++;
                    }

                    push @inner, $row if $fuzzy && $j && $inner;
                    $rows_filled++ if $fields_filled;
                }
            }

            #XXX: would be VERY nice to print as we go rather than spool everything, esp. for large files
            unless ($r->{util_args}{count}) {
                $r->{code_print_row}->($row);
            }
        } # for target data row


        #JDP: Inner fill, append multi-matched fuzzy source rows
        if( $inner ){
            foreach my $row ( @inner ){
                $r->{code_print_row}->($row);
            }
        }

        if ($r->{util_args}{count}) {
            $r->{result} = [200, "OK", $rows_filled];
        }
    }
);

1;
# ABSTRACT: