view release on metacpan or  search on metacpan

lib/AnyData.pm  view on Meta::CPAN

         if $flags->{col_names} and 'ru' =~ /$read_mode/;
    #####################################################
    # Patch from Wes Hardaker
    #####################################################
    # $ad->open_table( $file, $read_mode );
##    $ad->open_table( $file, $read_mode, $tname );
    $ad->open_table( $file, $read_mode, $tname );
#    use Data::Dumper; my $x = $ad; delete $x->{parser}->{twig}; delete $x->{parser}->{record_tag}; delete $x->{parser}->{current_element}; print Dumper $x;
    #####################################################
    return $ad;
}

sub open_table     {
    my $self = shift;
    $self->{storage}->open_table( $self->{parser}, @_ );
    my $col_names = $self->col_names();
    $self->{parser}->{key} ||= '';
    $self->{parser}->{key} ||= $col_names->[0] if $col_names->[0];
}
##################################################################


##################################################################
# TIEDHASH STUFF
##################################################################
sub key_col          { shift->{parser}->{key} }

sub fetchrow_hashref {
    my $self = shift;
    my $rec = $self->get_undeleted_record or return undef;
    my  @fields = ref $rec eq 'ARRAY'
            ? @$rec
            : $self->{parser}->read_fields($rec);
    my $col_names = $self->col_names();
    return undef unless scalar @fields;
    return undef if scalar @fields == 1 and !defined $fields[0];
    my $rowhash;
    @{$rowhash}{@$col_names} = @fields;
    return ( $rowhash );
}
sub get_undeleted_record {
    my $self = shift;
    my $rec;
    my $found=0;
    return $self->fetch_row if $self->parser_type eq 'XML';
    while (!$found) {
        my $test = $rec    = $self->{storage}->file2str($self->{parser});
        return  if !defined $rec;
        next if $self->{storage}->is_deleted($self->{parser});
        next if $self->{parser}->{skip_pattern} 
            and $rec =~ $self->{parser}->{skip_pattern};
        last;
    }
    return $rec;
#    return $rec if ref $rec eq 'ARRAY';
#    return unless $rec;
#    my @fields = $self->{parser}->read_fields($rec);
#    return undef if scalar @fields == 1 and !defined $fields[0];
#    return \@fields;
}
sub update_single_row {
    my $self     = shift;
    my $oldrow   = shift;
    my $newvals  = shift;
    my @colnames = @{ $self->col_names };
    my @newrow;
    my $requested_cols = [];
    for my $i(0..$#colnames) {
        push @$requested_cols, $colnames[$i] if defined $newvals->{$colnames[$i]};
        $newrow[$i] = $newvals->{$colnames[$i]};
        $newrow[$i] = $oldrow->{$colnames[$i]} unless defined $newrow[$i];
    }
    unshift @newrow, $requested_cols;
    $self->{storage}->seek(0,2);
    $self->push_row( @newrow );
    return \@newrow;
}
sub update_multiple_rows {
    my $self   = shift;
    my $key    = shift;
    my $values = shift;
    $self->seek_first_record;
    my @rows_to_update;
    while (my $row = $self->fetchrow_hashref) {
        next unless $self->match($row,$key);
        $self->{parser}->{has_update_function}
            ? $self->update_single_row($row,$values)
            : $self->delete_single_row();
        $self->{parser}->{has_update_function}
            ? push @rows_to_update,1
            : push @rows_to_update,$row;
    }
    if (!$self->{parser}->{has_update_function}) {
        for (@rows_to_update) {
           $self->update_single_row($_,$values);
	 }
    }
    return scalar @rows_to_update;
}
sub match {
    my($self,$row,$key) = @_;
    if ( ref $key ne 'HASH') {
        return 0 if !$row->{$self->key_col}
                 or  $row->{$self->key_col} ne $key;
        return 1;
    }
    my $found = 0;
    while (my($col,$re)=each %$key) {
        next unless defined $row->{$col} and is_matched($row->{$col},$re);
        $found++;
    }
    return 1 if $found == scalar keys %$key;
}
sub is_matched {
    my($str,$re)=@_;
    if (ref $re eq 'Regexp') {
        return $str =~ /$re/ ? 1 : 0;
    }
    my($op,$val);
    
    if ( $re and $re =~/^(\S*)\s+(.*)/ ) {
        $op  = $1;
        $val = $2;
    }
    elsif ($re) {
        return $str =~ /$re/ ? 1 : 0;
    }
    else {
        return $str eq '' ? 1 : 0;
    }
    my $numop = '< > == != <= >=';
    my $chrop = 'lt gt eq ne le ge';
    if (!($numop =~ /$op/) and !($chrop =~ /$op/)) {
        return $str =~ /$re/ ? 1 : 0;
    }
    if ($op eq '<' ) { return $str <  $val; }
    if ($op eq '>' ) { return $str >  $val; }
    if ($op eq '==') { return $str == $val; }