Эээ... Эт сликом сложно
. И опять же не то, что надо. Мне бы с фиксированными полями. Вот накидал уже
TextDB.pm
--
package TextDB;
sub new
{
my ($class,%args) = @_;
my $self = bless {}, $class;
$self->{opened} = 0;
$self->{filename} = $args{filename};
$self->{fields} = {}; # map
$self->{values} = []; # values
$self->{recordsize} = 0;
$self->{recordcount} = 0;
$self->{filemode} = $args{filemode} || ">";
my $fh;
if (open($fh,$self->{filemode}.$self->{filename}))
{
$self->{opened} = 1;
$self->{fh} = $fh;
if ($self->{lockmode})
{
_flock($fh,$self->{lockmode});
}
my $head = $args{head};
my $format = "";
my $fieldlist = "";
my $i = 0;
for $fieldpair (@{$head})
{
my ($field,$length) = split(\',\',$fieldpair);
$format .= "A".$length;
if ($fieldlist eq "")
{
$fieldlist = $field;
}
else
{
$fieldlist .= ",".$field;
}
$self->{fields}{$field} = $i;
$self->{values}[$i] = \'\';
$self->{recordsize} += 0 + $length;
$i++;
}
$self->{recordsize}++;
print $fh $format.chr(13);
print $fh $fieldlist.chr(13);
$self->{format} = $format;
if ($args{autoclose})
{
close($fh);
undef($self->{fh});
$self->{opened} = 0;
}
else
{
$self->{dataoffset} = tell($fh);
}
}
return $self;
}
sub opendb
{
my ($class,%args) = @_;
my $self = bless {}, $class;
$self->{opened} = 0;
$self->{filename} = $args{filename};
$self->{fields} = {}; # map
$self->{values} = []; # values
$self->{recordsize} = 0;
$self->{format} = "";
$self->{filemode} = $args{filemode} || "<";
my $fh;
if (open($fh,$self->{filemode}.$self->{filename}))
{
$self->{opened} = 1;
$self->{fh} = $fh;
if ($self->{lockmode})
{
_flock($fh,$self->{lockmode});
}
my $sore_nl = $/;
$/ = chr(13);
chomp(my $format = <$fh>);
chomp(my $fieldlist = <$fh>);
$/ = $store_nl;
my @lengths = split(\'A\',substr($format,1));
$self->{format} = $format;
for (@lengths)
{
$self->{recordsize} += 0 + $_;
}
$self->{recordsize}++;
$self->{recordcount} = int(((-s $self->{filename}) - $self->{dataoffset}) / $self->{recordsize});
my @fieldlist = split(\',\',$fieldlist);
my $i = 0;
for $field (@fieldlist)
{
$self->{fields}{$field} = $i;
$self->{values}[$i] = \'\';
$i++;
}
$self->{dataoffset} = tell($fh);
}
return $self;
}
sub field
{
my $self = shift;
my $fieldname = shift;
my $fieldno = $self->{fields}{$fieldname};
my $value = $self->{values}[$fieldno];
if (@_) { $self->{values}[$fieldno] = shift;}
return $value;
}
sub append
{
my $self = shift;
if (@_)
{
my %values = @_;
while (my ($field,$value) = each(%values))
{
$self->{values}[$self->{fields}{$field}] = $value;
}
}
seek($self->{fh},0,2);
print {$self->{fh}} pack($self->{format},@{$self->{values}});
print {$self->{fh}} chr(13);
$self->{recordcount}++;
}
sub close
{
if ($self->{opened})
{
close($self->{fh});
undef($self->{fh});
$self->{opened} = 0;
}
}
sub read
{
my ($self,$pos) = @_;
if ($self->{opened})
{
seek($self->{fh},$self->{dataoffset}+$pos*$self->{recordsize},0);
my $fh = $self->{fh};
my $record = <$fh>;
@{$self->{values}} = unpack($self->{format},$record);
}
}
sub update
{
my ($self,$pos,$record) = @_;
$self->read($pos);
while (my ($field,$value) = each(%$record))
{
$self->{values}[$self->{fields}{$field}] = $value;
}
seek($self->{fh},-$self->{recordsize},1);
print {$self->{fh}} pack($self->{format},@{$self->{values}});
print {$self->{fh}} chr(13);
}
return true;
--
testdb.pl
--
use lib \'F:\\Apache\\sites\\test\\cgi-bin\';
use TextDB;
print "-- New --\\n";
$tdb = new TextDB(
filename => \'f:\\test.db\',
head => ["field1,10","field2,10","field3,20"]
);
$tdb->field("field1","It\'s a field 1");
$tdb->field("field2",2);
$tdb->field("field3","field 3");
print "field1 = ".$tdb->field("field1");
print "\\n";
print "field2 = ".$tdb->field("field2");
print "\\n";
print "field3 = ".$tdb->field("field3");
print "\\n";
$tdb->append();
$tdb->append(field1=>"one two three",field3=>100);
print "offset = ".$tdb->{dataoffset};
print "\\n";
print "rec size = ".$tdb->{recordsize};
print "\\n";
$tdb->close();
undef($tdb);
print "-- Open --\\n";
$tdb = opendb TextDB(filename => \'f:\\test.db\',filemode => "+<");
print "offset = ".$tdb->{dataoffset};
print "\\n";
print "rec size = ".$tdb->{recordsize};
print "\\n";
$tdb->append(field1=>20,field2=>"open test");
for ($i=0;$i < $tdb->{recordcount};$i++)
{
print "record # $i\\n";
$tdb->read($i);
print "field1 = ".$tdb->field("field1");
print "\\n";
print "field2 = ".$tdb->field("field2");
print "\\n";
print "field3 = ".$tdb->field("field3");
print "\\n";
}
$tdb->update(2,{field3 => \'updated\'});
print "-- Update -- \\n";
for ($i=0;$i < $tdb->{recordcount};$i++)
{
print "record # $i\\n";
$tdb->read($i);
print "field1 = ".$tdb->field("field1");
print "\\n";
print "field2 = ".$tdb->field("field2");
print "\\n";
print "field3 = ".$tdb->field("field3");
print "\\n";
}
$tdb->close();
Правда остается проблема с особождением хэндла. Так и не хочет сволочь освобождать файл по нормальному. Приходится делать undef($tdb). Это более менее терпимо, но всеравно неприятно
