view release on metacpan or  search on metacpan

lib/Fsdb/Filter.pm  view on Meta::CPAN

=cut

sub create_compare_code ($$;$$) {
    my($self, $a_fsdb, $b_fsdb, $a_name, $b_name) = @_;
    $a_name = 'a' if (!defined($a_name));
    $b_name = 'b' if (!defined($b_name));

    #
    # A word about the 'no warnings "numeric"' bit:
    # we want to compare numeric data with <=>, 
    # but that emits warnings for our empty value "-".
    # We COULD filter that in Perl, but all the checking would make
    # it much, much slower, and the Perl core has to check anyway.
    # It turns out, <=> does The Right Thing,
    # in that (any non-numeric) == (any non-numeric)
    # and (any non-numeric) < (any numeric).
    # So we just turn off warnings.
    # But. Just. Here.
    #
    my $compare_code = "sub {\n" .
	    "\tno warnings \"numeric\";\n" .
        "\t\treturn\n";
    my($MODE_AUTO, $MODE_NUMERIC, $MODE_LEXICAL) = (0..10);
    my ($reverse, $sort_mode) = (0, $MODE_AUTO);
    my $arg;
    my $fields_found = 0;
    foreach $arg (@{$self->{_sort_argv}}) {
	if ($arg eq '-r') {
	    $reverse = 1;
	} elsif ($arg eq '-R') {
	    $reverse = 0;
	} elsif ($arg eq '-n') {
	    $sort_mode = $MODE_NUMERIC;
	} elsif ($arg eq '-N') {
	    $sort_mode = $MODE_LEXICAL;
	} elsif ($arg eq '-t') {
	    $sort_mode = $MODE_AUTO;
        } elsif ($arg =~ /^-/) {
	    croak $self->{_prog} . ": internal error: unknown option $arg in sort key\n";
	} else {
	    my ($left) = ($reverse ? $b_name : $a_name);
	    my ($right) = ($reverse ? $a_name : $b_name);
	    my $left_coli = $a_fsdb->col_to_i($arg);
	    my $right_coli = $b_fsdb->col_to_i($arg);
	    if ($reverse) {
		my $tmp_coli = $left_coli;
		$left_coli = $right_coli;
		$right_coli = $tmp_coli;
	    };
	    croak $self->{_prog} . ": unknown column name $arg in sort key\n"
		if (!defined($left_coli) || !defined($right_coli));
            my($this_sort_mode) = ($sort_mode == $MODE_AUTO ? ($a_fsdb->col_type_is_numeric($left_coli) ? $MODE_NUMERIC : $MODE_LEXICAL) : $sort_mode);
	    my($comparison_op) = ($this_sort_mode == $MODE_NUMERIC ? "<=>" : ($this_sort_mode == $MODE_LEXICAL ? "cmp": undef));
	    $compare_code .= "\t" . '($' . $left . '->[' . $left_coli . '] ' .
    	    	    $comparison_op .
		    ' $' . $right . '->[' . $right_coli . ']) || ' .
		    ' # ' . $arg  .
		    ($reverse ? ", descending" : ", ascending") .
		    ($comparison_op eq '<=>' ? " numeric" : " lexical") .
		    "\n";
	    # note that we don't currently handle NaN comparisons returning undef
	    $fields_found++;
	};
    };
    $compare_code .= "\t0; # match\n};\n";
    return undef if ($fields_found == 0);
    return $compare_code;
}

=head2 numeric_formatting

    $out = $self->numeric_formatting($x)

Display a floating point number $x using $self->{_format},
handling possible non-numeric "-" as a special case.

=cut

sub numeric_formatting {
    my ($self, $x) = @_;
    return $x if ($x eq '-');
    return sprintf($self->{_format}, $x);
}

=head2 setup_exactly_two_inputs

    $self->setup_exactly_two_inputs

Ensure that there are exactly two input streams.
Common to L<dbmerge> and L<dbjoin>.

=cut

sub setup_exactly_two_inputs {
    my($self) = @_;
    if ($#{$self->{_inputs}} == -1) {
	croak $self->{_prog} . ": too few input sources specified, use --input.\n";
    };
    if ($#{$self->{_inputs}} > 1) {
	croak $self->{_prog} . ": too input sources specified, dbmerge only hanldes two at once.\n";
    };
    if ($#{$self->{_inputs}} == 0) {
	# need to use stdin?
#	my $token = new IO::Handle;
#	$token->fdopen(fileno(STDIN), "r");
#	unshift @{$self->{_inputs}}, $token;
	unshift @{$self->{_inputs}}, '-';
    };
    croak if ($#{$self->{_inputs}} != 1);   # assert
}


=head1 NON-CLASS UTILITY ROUTINES

Filter also has some utility routines that are not part of the class structure.
They are not exported.

(none currently)

=cut