view release on metacpan or  search on metacpan

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

	my %fuzzy = map {$_->[0]=>1, $_->[1]=>1} @fuzzy;
	map { die [400, "Cannot use the same field for both exact and fuzzy expression matching"] if
		  $fuzzy{$_->[0]} or  $fuzzy{$_->[1]} } @lookup_fields;

        my %fill_fields; # key=fieldname-in-target, val=fieldname-in-source
        {
            my @ff = ref($r->{util_args}{fill_fields}) eq 'ARRAY' ?
                @{$r->{util_args}{fill_fields}} : split(/,/, $r->{util_args}{fill_fields});
            for my $field_idx (0..$#ff) {
                my @ff2 = split /:/, $ff[$field_idx], 2;
                if (@ff2 < 2) {
                    $ff2[1] = $ff2[0];
                }
                $fill_fields{ $ff2[0] } = $ff2[1];
            }
        }

        # these are the keys that we add to the stash
        $r->{lookup_fields} = \@lookup_fields;
	$r->{fuzzy} = \@fuzzy;
        $r->{fill_fields} = \%fill_fields;
        $r->{source_fields_idx} = [];
        $r->{source_fields} = [];
        $r->{source_data_rows} = [];
        $r->{target_fields_idx} = [];
        $r->{target_fields} = [];
        $r->{target_data_rows} = [];
    },

    on_input_header_row => sub {
        my $r = shift;

	#TARGET
        if ($r->{input_filenum} == 1) {
	    #JDP: Optionally append fuzzy matched target fields
	    if( $r->{util_args}{regex_fill} ){
		$r->{fill_fields}->{ join '.', @{$_} }=$_->[1] foreach
		    @{$r->{fuzzy}};
	    }

	    #JDP: lookup-fields has undocumented expectation of headers for
	    #     empty target columns. This provides more DWIM behavior by
	    #     patching in implicit headers a la csv-add-fields
	    my $target_count = @{ $r->{input_fields} };
	    my %target_fields = map {$_=>1} @{ $r->{input_fields} };
	    foreach my $field ( keys %{ $r->{fill_fields} } ){
		unless( exists($target_fields{$field}) ){
		    push @{ $r->{input_fields} }, $field;
		    $r->{input_fields_idx}->{$field}=$target_count++;
		}
	    }

	    $r->{target_fields}     = $r->{input_fields};
	    $r->{target_fields_idx} = $r->{input_fields_idx};
	    $r->{output_fields}     = $r->{input_fields};

	    #JDP: Check join field names exist
	    #XXX Case-insensitivity?
	    foreach( @{$r->{lookup_fields}}, @{$r->{fuzzy}} ){
		my $out = $_->[0];
		die [404, "Unknown target field: $out"] unless
		    $r->{input_filenum}==1 && exists $r->{target_fields_idx}->{$out};
	    }
	    foreach my $k ( keys %{$r->{fill_fields}} ){
		die [404, "Unknown target fill field: $k"] unless
		    $r->{input_filenum}==1 && exists $r->{target_fields_idx}->{$k};
	    }

	#SOURCE
	} else {
            $r->{source_fields}     = $r->{input_fields};
            $r->{source_fields_idx} = $r->{input_fields_idx};

	    #JDP: Check join field names exist
	    #XXX Case-insensitivity?
	    foreach( @{$r->{lookup_fields}}, @{$r->{fuzzy}} ){
		my $src = $_->[1];
		die [404, "Unknown source field: $src"] unless
		$r->{input_filenum}==2 && exists $r->{source_fields_idx}->{$src};
	    }
	    foreach my $v ( values %{$r->{fill_fields}} ){
		die [404, "Unknown source fill field: $v"] unless
		    $r->{input_filenum}!=1 && exists $r->{source_fields_idx}->{$v};
	    }

	}

    },

    on_input_data_row => sub {
        my $r = shift;
        if ($r->{input_filenum} == 1) {
            push @{ $r->{target_data_rows} }, $r->{input_row};
        } else {
            push @{ $r->{source_data_rows} }, $r->{input_row};
        }
    },


    after_close_input_files => sub {
        my $r = shift;

        my $ci = $r->{util_args}{ignore_case};
        #my $fuzzy = exists($r->{util_args}{regex}) ? 1 : 0;
        my $fuzzy = scalar @{ $r->{fuzzy} };

        #Prep key separator. Original use of | is a bad option for fuzzy regex mode
        my $keySepIN = $r->{util_args}{key_record_separator};
        my $keySep = eval{chr("0$1")} if defined($keySepIN) && $keySepIN =~ /^0(x\{?[0-9a-fA-F]+\}?|[0-9+]{2})$/;
        $keySep = "\000" if $@;
        $keySep //= "\000";

        my @inner;
        my $inner = $r->{util_args}{inner};
        eval 'use Storable' if $inner;
        if( $@ ){
            warn "Cannot load Storable, unable to fulfill --inner: $@\n";
            $inner = 0;
        }

        # 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';
            }