use
vars
qw( $VERSION $DEBUG $errstr $FIXERRORS @EXPORT @EXPORT_OK
@ISA $FIXPROBLEMS )
;
@ISA
=
qw(Exporter)
;
@EXPORT
=
qw( DEBUG FIXPROBLEMS Error Warning NullError )
;
@EXPORT_OK
=
qw( DEBUG FIXPROBLEMS Error Warning NullError )
;
$VERSION
=
"0.034"
;
$DEBUG
= 0;
sub
DEBUG () {
$DEBUG
};
$FIXPROBLEMS
= 1;
sub
FIXPROBLEMS () {
$FIXPROBLEMS
}
$errstr
=
''
;
sub
errstr () {
$errstr
}
sub
Warning (@)
{
if
(not FIXPROBLEMS) { Error(
@_
);
return
; }
shift
if
ref
$_
[0];
print
STDERR
"Warning: "
,
@_
if
DEBUG;
}
sub
Error (@)
{
shift
if
ref
$_
[0];
print
STDERR
@_
if
DEBUG;
$errstr
.=
join
''
,
@_
;
}
sub
NullError () {
$errstr
=
''
; }
sub
new
{
NullError();
my
$class
=
shift
;
my
$new
= {};
bless
$new
,
$class
;
if
(
@_
) {
$new
->
open
(
shift
) and
return
$new
;
return
; }
return
$new
;
}
sub
open
{
NullError();
my
$self
=
shift
;
if
(
@_
and not
defined
$self
->{
'filename'
})
{
$self
->{
'filename'
} =
shift
; }
return
1
if
defined
$self
->{
'opened'
};
my
$fh
= new IO::File;
my
(
$filename
,
$writable
,
$mode
) = (
$self
->{
'filename'
}, 0,
'r'
);
(
$writable
,
$mode
) = (1,
'r+'
)
if
-w
$filename
;
$fh
->
open
(
$filename
,
$mode
) or
do
{ Error
"Error opening file $filename: $!\n"
;
return
; };
my
$perms
= (
stat
(
$filename
))[2] & 0777;
@{
$self
}{
qw( opened fh writable perms )
}
= ( 1,
$fh
,
$writable
,
$perms
);
unless
(
$self
->can(
'read_header'
))
{ Error
"Method read_header not defined for $self\n"
;
return
; }
unless
(
$self
->read_header())
{
return
; }
1;
}
sub
close
{
NullError();
my
$self
=
shift
;
if
(not
defined
$self
->{
'opened'
})
{ Error
"Can't close file that is not opened\n"
;
return
; }
$self
->{
'fh'
}->
close
();
delete
@{
$self
}{
'opened'
,
'fh'
};
1;
}
sub
drop
{
NullError();
my
$self
=
shift
;
my
$filename
=
$self
;
if
(
ref
$self
)
{
$filename
=
$self
->{
'filename'
};
$self
->
close
()
if
(
$self
->{
'opened'
});
}
unlink
$filename
or
do
{ Error
"Error unlinking file $filename: $!\n"
;
return
; };
1;
}
sub
create_file
{
my
$self
=
shift
;
my
(
$name
,
$perms
) =
@_
;
if
(not
defined
$name
)
{
Error
"Name has to be specified when creating new table\n"
;
return
;
}
if
(-f
$name
)
{
Error
"File '$name' already exists\n"
;
return
;
}
my
$fh
= new IO::File;
$fh
->
open
(
$name
,
"w+"
,
$perms
) and
do
{
@{
$self
}{
qw( fh filename perms writable opened )
}
= (
$fh
,
$name
,
$perms
, 1, 1 );
return
$self
;
};
return
;
}
sub
get_record_offset
{
my
$self
=
shift
;
my
(
$header_len
,
$record_len
) = @{
$self
}{
qw( header_len record_len )
};
unless
(
defined
$header_len
and
defined
$record_len
)
{
Error
"Header and record lengths not known in get_record_offset\n"
;
return
;
}
my
$num
=
shift
;
unless
(
defined
$num
)
{
Error
"Number of the record must be specified in get_record_offset\n"
;
return
;
}
return
$header_len
+
$num
*
$record_len
;
}
sub
seek_to_record
{
my
(
$self
,
$num
) =
@_
;
my
$offset
=
$self
->get_record_offset(
$num
);
return
unless
defined
$offset
;
$self
->seek_to(
$offset
);
}
sub
seek_to
{
my
(
$self
,
$offset
) =
@_
;
return
1
if
defined
$self
->{
'tell'
} and
$self
->{
'tell'
} ==
$offset
;
my
$filename
=
$self
->{
'filename'
};
if
(not
defined
$self
->{
'opened'
})
{ Error
"The file $filename is not opened\n"
;
return
; }
if
(not
$self
->{
'writable'
})
{ Error
"The file $filename is not writable\n"
;
return
; }
delete
$self
->{
'tell'
};
$self
->{
'fh'
}->
seek
(
$offset
, 0)
or
do
{ Error
"Error seeking to offset $offset on $filename: $!\n"
;
return
;
};
1;
}
sub
read_record
{
my
(
$self
,
$num
,
$in_length
) =
@_
;
if
(not
defined
$num
)
{ Error
"Record number to read must be specified\n"
;
return
; }
if
(
$num
>
$self
->last_record())
{ Error
"Can't read record $num, there is not so many of them\n"
;
return
; }
if
(
defined
$self
->{
'cached_num'
} and
$num
==
$self
->{
'cached_num'
})
{
my
$data
=
$self
->{
'cached_data'
};
if
(
ref
$data
) {
return
@$data
; }
return
$data
;
}
my
$tell
=
$self
->{
'tell'
};
$self
->seek_to_record(
$num
) or
return
;
my
(
$fh
,
$record_len
) = @{
$self
}{
qw( fh record_len )
};
my
$buffer
;
my
$length
=
$record_len
if
((not
defined
$in_length
) or
$in_length
== -1);
my
$readlen
=
$fh
->
read
(
$buffer
,
$length
);
if
((not
defined
$in_length
or
$in_length
!= -1) and
$readlen
!=
$length
)
{
Warning
"Error reading the whole record num $num\n"
;
return
unless
FIXPROBLEMS;
};
$self
->{
'tell'
} = (
defined
$tell
) ?
$tell
+
$length
:
$fh
->
tell
();
$self
->{
'cached_num'
} =
$num
;
if
(
defined
$self
->{
'unpack_template'
})
{
my
@data
=
unpack
$self
->{
'unpack_template'
},
$buffer
;
$self
->{
'cached_data'
} = [
@data
];
return
@data
;
}
else
{
$self
->{
'cached_data'
} =
$buffer
;
return
$buffer
;
}
}
sub
write_record
{
my
(
$self
,
$num
) = (
shift
,
shift
);
if
(not
defined
$num
)
{ Error
"Record number to write must be specified\n"
;
return
; }
if
(
defined
$self
->{
'cached_num'
} and
$num
==
$self
->{
'cached_num'
})
{
delete
$self
->{
'cached_num'
}; }
$self
->seek_to_record(
$num
) or
return
;
delete
$self
->{
'tell'
};
local
($,, $\) = (
""
,
""
);
my
$fh
=
$self
->{
'fh'
};
$fh
->
print
(
@_
) or
do
{ Error
"Error writing record $num: $!\n"
;
return
; } ;
(
$num
== 0 ) ?
"0E0"
:
$num
;
}
sub
write_to
{
my
(
$self
,
$offset
) = (
shift
,
shift
);
$self
->seek_to(
$offset
) or
return
;
delete
$self
->{
'tell'
};
local
($,, $\) = (
""
,
""
);
my
$fh
=
$self
->{
'fh'
};
$fh
->
print
(
@_
) or
do
{ Error
"Error writing at offset $offset: $!\n"
;
return
; } ;
(
$offset
== 0 ) ?
"0E0"
:
$offset
;
}
1;