package VCP::DB_File::sdbm; =head1 NAME VCP::DB_File::sdbm - Subclass providing SDBM_File storage =head1 SYNOPSIS use VCP::DB_File; VCP::DB_File->new; =head1 DESCRIPTION To write your own DB_File filetype, copy this file and alter it. Then ask us to add an option to the .vcp file parsing to enable it. =over =for test_script t/01db_file_sdbm.t =cut $VERSION = 1 ; @ISA = qw( VCP::DB_File ); use strict ; use VCP::Debug qw( :debug ); use Fcntl; use File::Spec; use SDBM_File; use VCP::DB_File; use VCP::Debug qw( :debug ); use VCP::Logger qw( lg BUG ); #use base qw( VCP::DB_File ); #use fields ( # 'Hash', ## The hash we tie #); sub db_file { my $self = shift; return File::Spec->catfile( $self->store_loc, "db" ); } sub close_db { my $self = shift; return unless $self->{Hash}; $self->SUPER::close_db; $self->{Hash} = undef; close $self->{AbbreviationsFH}; $self->{AbbreviationsFH} = undef; } sub delete_db { my $self = shift; my $store_files_pattern = $self->store_loc . "/*"; my $has_store_files = -e $self->store_loc; if ( $has_store_files ) { require File::Glob; my @store_files = File::Glob::glob( $store_files_pattern ); $has_store_files &&= @store_files; } return unless $has_store_files; $self->SUPER::delete_db; $self->rmdir_store_loc unless $ENV{VCPNODELETE}; } sub open_abbreviations_file { my $self = shift; my ( $fn ) = @_; local *ABBREVIATIONS; $self->{CurrentAbbreviation} = 0; my $abbrev_fn = "${fn}_abbreviations.txt"; open ABBREVIATIONS, "+>> $abbrev_fn" or die "$!: $abbrev_fn"; seek ABBREVIATIONS, 0, 0; while () { chomp; my ( $abbrev, $key ) = split /\s+/, $_, 2; $self->{KeysByAbbreviation}->{$abbrev} = $key; $self->{AbbreviationsByKey}->{$key} = $abbrev; ( $self->{CurrentAbbreviation} ) = $abbrev =~ /(\d+)/;; } $self->{AbbreviationsFH} = *ABBREVIATIONS{IO}; } sub open_db { my $self = shift; $self->SUPER::open_db; $self->mkdir_store_loc; $self->{Hash} = {}; my $fn = $self->db_file; tie %{$self->{Hash}}, "SDBM_File", $fn, O_RDWR|O_CREAT, 0660 or die "$! while opening DB_File SDBM file '$fn'"; $self->open_abbreviations_file( $fn ); } sub open_existing_db { my $self = shift; $self->SUPER::open_db; $self->mkdir_store_loc; $self->{Hash} = {}; my $fn = $self->db_file; tie %{$self->{Hash}}, "SDBM_File", $fn, O_RDWR, 0 or die "$! while opening DB_File SDBM file '$fn'"; $self->open_abbreviations_file( $fn ); } sub raw_set { ## so big_records.pm can call us with prepacked stuff my $self = shift; my ( $key, $value ) = @_; if ( exists $self->{AbbreviationsByKey}->{$key} ) { $key = $self->{AbbreviationsByKey}->{$key}; } elsif ( length( $key ) + length( $value ) > 20 ) { ## Work around SBDM's 1008 byte record limit, assuming that ## our values are smaller than 990 bytes or so. my $abbrev = sprintf( ";;;;;;;;ABBREV_%010d", ++$self->{CurrentAbbreviation} ); ## Semicolons are used to join fields in a key, here we ## assume no keys will be composed of a bunch of empty ## fields and a field like "ABBREV_0000190" $self->{AbbreviationsByKey}->{$key} = $abbrev; $self->{KeysByAbbreviations}->{$abbrev} = $key; my $fh = $self->{AbbreviationsFH}; print $fh "$abbrev $key\n"; lg "Abbreviating \"$key\" as \"$abbrev\""; $key = $abbrev; } $self->{Hash}->{$key} = $value; } sub set { my $self = shift; my $key_parts = shift; BUG "key must be an ARRAY reference" unless ref $key_parts eq "ARRAY"; debug "setting ", ref $self, " ", join( ",", @$key_parts ), " => ", join( ",", @_ ) if debugging; $self->raw_set( $self->pack_values( @$key_parts ), $self->pack_values( @_ ) ); } sub raw_get { my $self = shift; my $key = shift; if ( exists $self->{AbbreviationsByKey}->{$key} ) { $key = $self->{AbbreviationsByKey}->{$key}; } $self->{Hash}->{$key}; } sub get { my $self = shift; my $key_parts = shift; BUG "key must be an ARRAY reference" unless ref $key_parts eq "ARRAY"; BUG "extra args found" if @_; BUG "called in scalar context" if defined wantarray && !wantarray; my $key = $self->pack_values( @$key_parts ); my $v = $self->raw_get( $key ); return unless defined $v; $self->unpack_values( $v ); } sub exists { my $self = shift; my $key_parts = shift; BUG "key must be an ARRAY reference" unless ref $key_parts eq "ARRAY"; my $key = $self->pack_values( @$key_parts ); if ( exists $self->{AbbreviationsByKey}->{$key} ) { $key = $self->{AbbreviationsByKey}->{$key}; } return $self->{Hash}->{$key} ? 1 : 0; } sub keys { my $self = shift; map [ $self->unpack_values( $_ ) ], keys %{$self->{Hash}}; } =item dump $db->dump( \*STDOUT ); my $s = $db->dump; my @l = $db->dump; Dumps keys and values from a DB, in lexically sorted key order. If a filehandle reference is provided, prints to that filehandle. Otherwise, returns a string or array containing the entire dump, depending on context. =cut sub dump { my $self = shift; my $fh = @_ ? shift : undef; my( @keys, %vals ); my @w; while ( my ( $k, $v ) = each %{$self->{Hash}} ) { if ( exists $self->{KeysByAbbreviation}->{$k} ) { $k = $self->{KeysByAbbreviation}->{$k}; } my @key = $self->unpack_values( $k ); for ( my $i = 0; $i <= $#key; ++$i ) { $w[$i] = length $key[$i] if ! defined $w[$i] || length $key[$i] > $w[$i]; } push @keys, $k; $vals{$k} = [ $self->unpack_values( $v ) ]; } ## This does not take file separators in to account, but that's ok ## for a debugging tool and the ids that are used as key values ## are supposed to be opaque anyway @keys = sort @keys; # build format string my $f = join( " ", map "%-${w[$_]}s", 0..$#w ) . " => %s\n"; my @lines; while ( @keys ) { my $k = shift @keys; my @v = map { "'$_'" } @{$vals{$k}}; my $s = sprintf $f, $self->unpack_values( $k ), @v == 1 ? $v[0] : join join( ",", @v ), "(", ")"; if( defined $fh ) { print $fh $s; } else { push @lines, $s; } } unless( defined $fh ) { if( wantarray ) { chomp @lines; return @lines; } return join "", @lines; } } =back =head1 LIMITATIONS There is no way (yet) of telling the mapper to continue processing the rules list. We could implement labels like C< <>> > to be allowed before pattern expressions (but not between pattern and result), and we could then impelement C< <>> >. And a C< <> > could be used to fall through to the next label. All of which is wonderful, but I want to gain some real world experience with the current system and find a use case for gotos and fallthroughs before I implement them. This comment is here to solicit feedback :). =head1 AUTHOR Barrie Slaymaker =head1 COPYRIGHT Copyright (c) 2000, 2001, 2002 Perforce Software, Inc. All rights reserved. See L (C) for the terms of use. =cut 1