[dbsrgits/DBM-Deep.git] / lib / DBM / Deep / Storage / File.pm

package DBM::Deep::Storage::File;

use 5.006_000;

use strict;
use warnings FATAL => 'all';

use Fcntl qw( :DEFAULT :flock :seek );

use constant DEBUG => 0;

=head1 NAME

DBM::Deep::Storage::File

=head1 PURPOSE

This is an internal-use-only object for L<DBM::Deep/>. It mediates the low-level
interaction with the storage mechanism.

Currently, the only storage mechanism supported is the file system.

=head1 OVERVIEW

This class provides an abstraction to the storage mechanism so that the Engine
(the only class that uses this class) doesn't have to worry about that.

=head1 METHODS

=head2 new( \%args )

=cut

sub new {
    my $class = shift;
    my ($args) = @_;

    my $self = bless {
        autobless          => 1,
        autoflush          => 1,
        end                => 0,
        fh                 => undef,
        file               => undef,
        file_offset        => 0,
        locking            => 1,
        locked             => 0,
#XXX Migrate this to the engine, where it really belongs.
        filter_store_key   => undef,
        filter_store_value => undef,
        filter_fetch_key   => undef,
        filter_fetch_value => undef,
    }, $class;

    # Grab the parameters we want to use
    foreach my $param ( keys %$self ) {
        next unless exists $args->{$param};
        $self->{$param} = $args->{$param};
    }

    if ( $self->{fh} && !$self->{file_offset} ) {
        $self->{file_offset} = tell( $self->{fh} );
    }

    $self->open unless $self->{fh};

    return $self;
}

=head2 open()

This method opens the filehandle for the filename in C< file >. 

There is no return value.

=cut

sub open {
    my $self = shift;

    # Adding O_BINARY should remove the need for the binmode below. However,
    # I'm not going to remove it because I don't have the Win32 chops to be
    # absolutely certain everything will be ok.
    my $flags = O_CREAT | O_BINARY;

    if ( !-e $self->{file} || -w _ ) {
      $flags |= O_RDWR;
    }
    else {
      $flags |= O_RDONLY;
    }

    my $fh;
    sysopen( $fh, $self->{file}, $flags )
        or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n";
    $self->{fh} = $fh;

    # Even though we use O_BINARY, better be safe than sorry.
    binmode $fh;

    if ($self->{autoflush}) {
        my $old = select $fh;
        $|=1;
        select $old;
    }

    return 1;
}

=head2 close()

If the filehandle is opened, this will close it.

There is no return value.

=cut

sub close {
    my $self = shift;

    if ( $self->{fh} ) {
        close $self->{fh};
        $self->{fh} = undef;
    }

    return 1;
}

=head2 size()

This will return the size of the DB. If file_offset is set, this will take that into account.

=cut

sub size {
    my $self = shift;

    return 0 unless $self->{fh};
    return( (-s $self->{fh}) - $self->{file_offset} );
}

=head2 set_inode()

This will set the inode value of the underlying file object.

This is only needed to handle some obscure Win32 bugs. It reqlly shouldn't be
needed outside this object.

There is no return value.

=cut

sub set_inode {
    my $self = shift;

    unless ( defined $self->{inode} ) {
        my @stats = stat($self->{fh});
        $self->{inode} = $stats[1];
        $self->{end} = $stats[7];
    }

    return 1;
}

=head2 print_at( $offset, @data )

This takes an optional offset and some data to print.

C< $offset >, if defined, will be used to seek into the file. If file_offset is
set, it will be used as the zero location. If it is undefined, no seeking will
occur. Then, C< @data > will be printed to the current location.

There is no return value.

=cut

sub print_at {
    my $self = shift;
    my $loc  = shift;

    local ($/,$\);

    my $fh = $self->{fh};
    if ( defined $loc ) {
        seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
    }

    if ( DEBUG ) {
        my $caller = join ':', (caller)[0,2];
        my $len = length( join '', @_ );
        warn "($caller) print_at( " . (defined $loc ? $loc : '<undef>') . ", $len )\n";
    }

    print( $fh @_ ) or die "Internal Error (print_at($loc)): $!\n";

    return 1;
}

=head2 read_at( $offset, $length )

This takes an optional offset and a length.

C< $offset >, if defined, will be used to seek into the file. If file_offset is
set, it will be used as the zero location. If it is undefined, no seeking will
occur. Then, C< $length > bytes will be read from the current location.

The data read will be returned.

=cut

sub read_at {
    my $self = shift;
    my ($loc, $size) = @_;

    local ($/,$\);

    my $fh = $self->{fh};
    if ( defined $loc ) {
        seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
    }

    if ( DEBUG ) {
        my $caller = join ':', (caller)[0,2];
        warn "($caller) read_at( " . (defined $loc ? $loc : '<undef>') . ", $size )\n";
    }

    my $buffer;
    read( $fh, $buffer, $size);

    return $buffer;
}

=head2 DESTROY

When the ::Storage::File object goes out of scope, it will be closed.

=cut

sub DESTROY {
    my $self = shift;
    return unless $self;

    $self->close;

    return;
}

=head2 request_space( $size )

This takes a size and adds that much space to the DBM.

This returns the offset for the new location.

=cut

sub request_space {
    my $self = shift;
    my ($size) = @_;

    #XXX Do I need to reset $self->{end} here? I need a testcase
    my $loc = $self->{end};
    $self->{end} += $size;

    return $loc;
}

=head2 flush()

This flushes the filehandle. This takes no parameters and returns nothing.

=cut

sub flush {
    my $self = shift;

    # Flush the filehandle
    my $old_fh = select $self->{fh};
    my $old_af = $|; $| = 1; $| = $old_af;
    select $old_fh;

    return 1;
}

=head2 is_writable()

This takes no parameters. It returns a boolean saying if this filehandle is
writable.

Taken from L<http://www.perlmonks.org/?node_id=691054/>.

=cut

sub is_writable {
    my $self = shift;

    my $fh = $self->{fh};
    return unless defined $fh;
    return unless defined fileno $fh;
    local $\ = '';  # just in case
    no warnings;    # temporarily disable warnings
    local $^W;      # temporarily disable warnings
    return print $fh '';
}

=head2 copy_stats( $target_filename )

This will take the stats for the current filehandle and apply them to
C< $target_filename >. The stats copied are:

=over 4

=item * Onwer UID and GID

=item * Permissions

=back

=cut

sub copy_stats {
    my $self = shift;
    my ($temp_filename) = @_;

    my @stats = stat( $self->{fh} );
    my $perms = $stats[2] & 07777;
    my $uid = $stats[4];
    my $gid = $stats[5];
    chown( $uid, $gid, $temp_filename );
    chmod( $perms, $temp_filename );
}

=head1 LOCKING

This is where the actual locking of the storage medium is performed.
Nested locking is supported.

B<NOTE>: It is unclear what will happen if a read lock is taken, then
a write lock is taken as a nested lock, then the write lock is released.

Currently, the only locking method supported is flock(1). This is a
whole-file lock. In the future, more granular locking may be supported.
The API for that is unclear right now.

The following methods manage the locking status. In all cases, they take
a L<DBM::Deep/> object and returns nothing.

=over 4

=item * lock_exclusive( $obj )

Take a lock usable for writing.

=item * lock_shared( $obj )

Take a lock usable for reading.

=item * unlock( $obj )

Releases the last lock taken. If this is the outermost lock, then the
object is actually unlocked.

=back

=cut

sub lock_exclusive {
    my $self = shift;
    my ($obj) = @_;
    return $self->_lock( $obj, LOCK_EX );
}

sub lock_shared {
    my $self = shift;
    my ($obj) = @_;
    return $self->_lock( $obj, LOCK_SH );
}

sub _lock {
    my $self = shift;
    my ($obj, $type) = @_;

    $type = LOCK_EX unless defined $type;

    #XXX This is a temporary fix for Win32 and autovivification. It
    # needs to improve somehow. -RobK, 2008-03-09
    if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
        $type = LOCK_EX;
    }

    if (!defined($self->{fh})) { return; }

    #XXX This either needs to allow for upgrading a shared lock to an
    # exclusive lock or something else with autovivification.
    # -RobK, 2008-03-09
    if ($self->{locking}) {
        if (!$self->{locked}) {
            flock($self->{fh}, $type);

            # refresh end counter in case file has changed size
            my @stats = stat($self->{fh});
            $self->{end} = $stats[7];

            # double-check file inode, in case another process
            # has optimize()d our file while we were waiting.
            if (defined($self->{inode}) && $stats[1] != $self->{inode}) {
                $self->close;
                $self->open;

                #XXX This needs work
                $obj->{engine}->setup( $obj );

                flock($self->{fh}, $type); # re-lock

                # This may not be necessary after re-opening
                $self->{end} = (stat($self->{fh}))[7]; # re-end
            }
        }
        $self->{locked}++;

        return 1;
    }

    return;
}

sub unlock {
    my $self = shift;

    if (!defined($self->{fh})) { return; }

    if ($self->{locking} && $self->{locked} > 0) {
        $self->{locked}--;

        if (!$self->{locked}) {
            flock($self->{fh}, LOCK_UN);
            return 1;
        }

        return;
    }

    return;
}

1;
__END__
Commit	Line	Data
d426259c	1	package DBM::Deep::Storage::File;
460b1067	2
2120a181	3	use 5.006_000;
460b1067	4
460b1067	5	use strict;
065b45be	6	use warnings FATAL => 'all';
460b1067	7
86867f3a	8	use Fcntl qw( :DEFAULT :flock :seek );
460b1067	9
40963fba	10	use constant DEBUG => 0;
695c88b1	11
76855018	12	=head1 NAME
76855018	13
d426259c	14	DBM::Deep::Storage::File
76855018	15
	16	=head1 PURPOSE
	17
	18	This is an internal-use-only object for L<DBM::Deep/>. It mediates the low-level
	19	interaction with the storage mechanism.
	20
	21	Currently, the only storage mechanism supported is the file system.
	22
	23	=head1 OVERVIEW
	24
d426259c	25	This class provides an abstraction to the storage mechanism so that the Engine
d426259c	26	(the only class that uses this class) doesn't have to worry about that.
76855018	27
	28	=head1 METHODS
	29
	30	=head2 new( \%args )
	31
	32	=cut
	33
460b1067	34	sub new {
	35	my $class = shift;
	36	my ($args) = @_;
	37
	38	my $self = bless {
359a01ac	39	autobless => 1,
2120a181	40	autoflush => 1,
460b1067	41	end => 0,
	42	fh => undef,
	43	file => undef,
	44	file_offset => 0,
2120a181	45	locking => 1,
460b1067	46	locked => 0,
2120a181	47	#XXX Migrate this to the engine, where it really belongs.
460b1067	48	filter_store_key => undef,
	49	filter_store_value => undef,
	50	filter_fetch_key => undef,
	51	filter_fetch_value => undef,
	52	}, $class;
	53
	54	# Grab the parameters we want to use
	55	foreach my $param ( keys %$self ) {
	56	next unless exists $args->{$param};
	57	$self->{$param} = $args->{$param};
	58	}
	59
	60	if ( $self->{fh} && !$self->{file_offset} ) {
	61	$self->{file_offset} = tell( $self->{fh} );
	62	}
	63
	64	$self->open unless $self->{fh};
	65
	66	return $self;
	67	}
	68
76855018	69	=head2 open()
	70
	71	This method opens the filehandle for the filename in C< file >.
	72
	73	There is no return value.
	74
	75	=cut
	76
460b1067	77	sub open {
	78	my $self = shift;
	79
633df1fd	80	# Adding O_BINARY should remove the need for the binmode below. However,
460b1067	81	# I'm not going to remove it because I don't have the Win32 chops to be
460b1067	82	# absolutely certain everything will be ok.
e9b0b5f0	83	my $flags = O_CREAT \| O_BINARY;
	84
	85	if ( !-e $self->{file} \|\| -w _ ) {
	86	$flags \|= O_RDWR;
	87	}
	88	else {
	89	$flags \|= O_RDONLY;
	90	}
460b1067	91
	92	my $fh;
	93	sysopen( $fh, $self->{file}, $flags )
	94	or die "DBM::Deep: Cannot sysopen file '$self->{file}': $!\n";
	95	$self->{fh} = $fh;
	96
	97	# Even though we use O_BINARY, better be safe than sorry.
	98	binmode $fh;
	99
	100	if ($self->{autoflush}) {
	101	my $old = select $fh;
	102	$\|=1;
	103	select $old;
	104	}
	105
	106	return 1;
	107	}
	108
76855018	109	=head2 close()
	110
	111	If the filehandle is opened, this will close it.
	112
	113	There is no return value.
	114
	115	=cut
	116
460b1067	117	sub close {
	118	my $self = shift;
	119
	120	if ( $self->{fh} ) {
	121	close $self->{fh};
	122	$self->{fh} = undef;
	123	}
	124
	125	return 1;
	126	}
	127
76855018	128	=head2 size()
	129
	130	This will return the size of the DB. If file_offset is set, this will take that into account.
	131
	132	=cut
	133
00d9bd0b	134	sub size {
	135	my $self = shift;
	136
	137	return 0 unless $self->{fh};
f3c5ac06	138	return( (-s $self->{fh}) - $self->{file_offset} );
00d9bd0b	139	}
00d9bd0b	140
76855018	141	=head2 set_inode()
	142
	143	This will set the inode value of the underlying file object.
	144
d426259c	145	This is only needed to handle some obscure Win32 bugs. It reqlly shouldn't be
d426259c	146	needed outside this object.
76855018	147
	148	There is no return value.
	149
	150	=cut
	151
7dcefff3	152	sub set_inode {
	153	my $self = shift;
	154
2120a181	155	unless ( defined $self->{inode} ) {
7dcefff3	156	my @stats = stat($self->{fh});
	157	$self->{inode} = $stats[1];
	158	$self->{end} = $stats[7];
	159	}
	160
	161	return 1;
	162	}
	163
76855018	164	=head2 print_at( $offset, @data )
	165
	166	This takes an optional offset and some data to print.
	167
d426259c	168	C< $offset >, if defined, will be used to seek into the file. If file_offset is
	169	set, it will be used as the zero location. If it is undefined, no seeking will
	170	occur. Then, C< @data > will be printed to the current location.
76855018	171
	172	There is no return value.
	173
	174	=cut
	175
019404df	176	sub print_at {
	177	my $self = shift;
	178	my $loc = shift;
	179
	180	local ($/,$\);
	181
	182	my $fh = $self->{fh};
7dcefff3	183	if ( defined $loc ) {
	184	seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
	185	}
	186
695c88b1	187	if ( DEBUG ) {
	188	my $caller = join ':', (caller)[0,2];
	189	my $len = length( join '', @_ );
	190	warn "($caller) print_at( " . (defined $loc ? $loc : '<undef>') . ", $len )\n";
	191	}
	192
45f047f8	193	print( $fh @_ ) or die "Internal Error (print_at($loc)): $!\n";
019404df	194
	195	return 1;
	196	}
	197
76855018	198	=head2 read_at( $offset, $length )
	199
	200	This takes an optional offset and a length.
	201
d426259c	202	C< $offset >, if defined, will be used to seek into the file. If file_offset is
	203	set, it will be used as the zero location. If it is undefined, no seeking will
	204	occur. Then, C< $length > bytes will be read from the current location.
76855018	205
	206	The data read will be returned.
	207
	208	=cut
	209
7dcefff3	210	sub read_at {
	211	my $self = shift;
	212	my ($loc, $size) = @_;
	213
	214	local ($/,$\);
	215
	216	my $fh = $self->{fh};
	217	if ( defined $loc ) {
	218	seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
	219	}
	220
695c88b1	221	if ( DEBUG ) {
	222	my $caller = join ':', (caller)[0,2];
	223	warn "($caller) read_at( " . (defined $loc ? $loc : '<undef>') . ", $size )\n";
	224	}
	225
7dcefff3	226	my $buffer;
	227	read( $fh, $buffer, $size);
	228
	229	return $buffer;
	230	}
	231
76855018	232	=head2 DESTROY
76855018	233
d426259c	234	When the ::Storage::File object goes out of scope, it will be closed.
76855018	235
	236	=cut
	237
460b1067	238	sub DESTROY {
	239	my $self = shift;
	240	return unless $self;
	241
	242	$self->close;
	243
	244	return;
	245	}
	246
76855018	247	=head2 request_space( $size )
	248
	249	This takes a size and adds that much space to the DBM.
	250
	251	This returns the offset for the new location.
	252
	253	=cut
	254
019404df	255	sub request_space {
	256	my $self = shift;
	257	my ($size) = @_;
	258
7dcefff3	259	#XXX Do I need to reset $self->{end} here? I need a testcase
019404df	260	my $loc = $self->{end};
	261	$self->{end} += $size;
	262
	263	return $loc;
	264	}
	265
76855018	266	=head2 flush()
	267
	268	This flushes the filehandle. This takes no parameters and returns nothing.
	269
	270	=cut
	271
	272	sub flush {
	273	my $self = shift;
	274
	275	# Flush the filehandle
	276	my $old_fh = select $self->{fh};
	277	my $old_af = $\|; $\| = 1; $\| = $old_af;
	278	select $old_fh;
	279
	280	return 1;
	281	}
	282
	283	=head2 is_writable()
	284
	285	This takes no parameters. It returns a boolean saying if this filehandle is
	286	writable.
	287
	288	Taken from L<http://www.perlmonks.org/?node_id=691054/>.
	289
	290	=cut
	291
	292	sub is_writable {
	293	my $self = shift;
	294
	295	my $fh = $self->{fh};
	296	return unless defined $fh;
	297	return unless defined fileno $fh;
	298	local $\ = ''; # just in case
	299	no warnings; # temporarily disable warnings
	300	local $^W; # temporarily disable warnings
	301	return print $fh '';
	302	}
	303
	304	=head2 copy_stats( $target_filename )
	305
	306	This will take the stats for the current filehandle and apply them to
	307	C< $target_filename >. The stats copied are:
	308
	309	=over 4
	310
	311	=item * Onwer UID and GID
	312
	313	=item * Permissions
	314
	315	=back
	316
	317	=cut
	318
	319	sub copy_stats {
	320	my $self = shift;
	321	my ($temp_filename) = @_;
	322
	323	my @stats = stat( $self->{fh} );
	324	my $perms = $stats[2] & 07777;
	325	my $uid = $stats[4];
	326	my $gid = $stats[5];
	327	chown( $uid, $gid, $temp_filename );
	328	chmod( $perms, $temp_filename );
	329	}
330
331	=head1 LOCKING
332
333	This is where the actual locking of the storage medium is performed.
334	Nested locking is supported.
335
336	B<NOTE>: It is unclear what will happen if a read lock is taken, then
337	a write lock is taken as a nested lock, then the write lock is released.
338
339	Currently, the only locking method supported is flock(1). This is a
340	whole-file lock. In the future, more granular locking may be supported.
341	The API for that is unclear right now.
342
343	The following methods manage the locking status. In all cases, they take
344	a L<DBM::Deep/> object and returns nothing.
345
346	=over 4
347
348	=item * lock_exclusive( $obj )
349
350	Take a lock usable for writing.
351
352	=item * lock_shared( $obj )
353
354	Take a lock usable for reading.
355
356	=item * unlock( $obj )
357
358	Releases the last lock taken. If this is the outermost lock, then the
359	object is actually unlocked.
360
361	=back
362
363	=cut
364
5c0756fc	365	sub lock_exclusive {
	366	my $self = shift;
	367	my ($obj) = @_;
76855018	368	return $self->_lock( $obj, LOCK_EX );
5c0756fc	369	}
	370
	371	sub lock_shared {
	372	my $self = shift;
	373	my ($obj) = @_;
76855018	374	return $self->_lock( $obj, LOCK_SH );
5c0756fc	375	}
5c0756fc	376
76855018	377	sub _lock {
15ba72cc	378	my $self = shift;
15ba72cc	379	my ($obj, $type) = @_;
42717e46	380
15ba72cc	381	$type = LOCK_EX unless defined $type;
15ba72cc	382
45f047f8	383	#XXX This is a temporary fix for Win32 and autovivification. It
	384	# needs to improve somehow. -RobK, 2008-03-09
	385	if ( $^O eq 'MSWin32' \|\| $^O eq 'cygwin' ) {
	386	$type = LOCK_EX;
	387	}
	388
15ba72cc	389	if (!defined($self->{fh})) { return; }
15ba72cc	390
45f047f8	391	#XXX This either needs to allow for upgrading a shared lock to an
	392	# exclusive lock or something else with autovivification.
	393	# -RobK, 2008-03-09
15ba72cc	394	if ($self->{locking}) {
	395	if (!$self->{locked}) {
	396	flock($self->{fh}, $type);
	397
	398	# refresh end counter in case file has changed size
	399	my @stats = stat($self->{fh});
	400	$self->{end} = $stats[7];
	401
	402	# double-check file inode, in case another process
	403	# has optimize()d our file while we were waiting.
2120a181	404	if (defined($self->{inode}) && $stats[1] != $self->{inode}) {
15ba72cc	405	$self->close;
	406	$self->open;
	407
	408	#XXX This needs work
f4d0ac97	409	$obj->{engine}->setup( $obj );
15ba72cc	410
	411	flock($self->{fh}, $type); # re-lock
	412
	413	# This may not be necessary after re-opening
	414	$self->{end} = (stat($self->{fh}))[7]; # re-end
	415	}
	416	}
	417	$self->{locked}++;
	418
	419	return 1;
	420	}
	421
	422	return;
	423	}
	424
15ba72cc	425	sub unlock {
	426	my $self = shift;
	427
	428	if (!defined($self->{fh})) { return; }
	429
	430	if ($self->{locking} && $self->{locked} > 0) {
	431	$self->{locked}--;
15ba72cc	432
a8d2331c	433	if (!$self->{locked}) {
	434	flock($self->{fh}, LOCK_UN);
	435	return 1;
	436	}
	437
	438	return;
15ba72cc	439	}
	440
	441	return;
	442	}
	443
460b1067	444	1;
460b1067	445	__END__