view release on metacpan or  search on metacpan

lib/Video/TeletextDB/Access.pm  view on Meta::CPAN

package Video::TeletextDB::Access;
use 5.006001;
use strict;
use warnings;
use Carp;
use DB_File;
use POSIX qw(ENOENT EWOULDBLOCK);
use Fcntl qw(F_GETFL O_CREAT O_RDWR O_RDONLY O_ACCMODE LOCK_NB LOCK_EX);
# use AutoLoader qw(AUTOLOAD);

use Video::TeletextDB::Constants qw(:BdbPrefixes :VTX :VBI DB_VERSION);
use Video::TeletextDB::Page qw(vote $epoch_time);

our $VERSION = "0.02";
use base qw(Video::TeletextDB::Parameters);

use Exporter::Tidy
    functions => [qw(tilde)],
    variables => [qw($default_cache_dir $default_page_versions)];

use constant MIN_STORES	=> 10000; # Must have at least 10000 stores
use constant DB_RO	=> "Video::TeletextDB::DB_RO";
use constant DB_RW	=> "Video::TeletextDB::DB_RW";

our @CARP_NOT = qw(Video::TeletextDB::Options);

our $default_cache_dir = "~/.TeletextDB/cache";
our $default_page_versions = 5;

# Database format:
#  V.	=> a*  (version)
#  s.	=> NNN (start time, number of stores, last store time)
#  S.	=> C   (page_versions)
#  c.nn  (page, subpage) => CN (last_counter, last_time)
#        There is a fake c."\xff"x4 at the end to make scanning easier
#  p.nnC (page, subpage, counter) =>
#           Na* (store time, join \xa, raw rows (without \xa))
#        There is a fake p."\xff"x5 at the end to make scanning easier

sub tilde {
    defined(my $file = shift) || croak "Undefined file";
    my ($user, $rest) = $file =~ m!^~([^/]*)(.*)\z!s or return $file;
    if ($user ne "") {
        my @pw = getpwnam($user) or croak "Could not find user $user";
        $user = $pw[7];
    } elsif (!defined($user = $ENV{HOME})) {
        my @pw = getpwuid($>) or
            croak "Could not determine who you are";
        $user = $pw[7];
    }
    croak "Home directory is the empty string" if $user eq "";
    $user =~ s!/*\z!$rest!;
    $user = "/" if $user eq "";
    # Restore taintedness
    return $user . substr($file, 0, 0);
}

# Prepare a directory to contain databases
sub prepare {
    my ($class, $tele, $params) = @_;

    my $mkpath = exists $params->{mkpath} ?
        delete $params->{mkpath} : !exists $params->{cache_dir};
    my $dir = delete $params->{cache_dir};
    $dir = $default_cache_dir unless defined $dir;
    $dir = tilde($dir);
    if ($dir !~ m!\A/!) {
        require Cwd;
        my $prefix = Cwd::getcwd();
        $dir = $prefix =~ m!/\z! ? $prefix . $dir : "$prefix/$dir";
    }
    $dir .= "/" unless $dir =~ m!/\z!;
    if (!-d $dir) {
        croak "No visible directory named '$dir'" unless $mkpath;
        require File::Path;
        my $old_mask = umask($tele->{umask}) if defined($tele->{umask});
        eval { File::Path::mkpath($dir) };
        my $err = $@;
        umask($old_mask) if defined($tele->{umask});
        die $err if $err;
    }
    $tele->{cache_dir} = $dir;
}

# Opening a db file with O_CREAT can give you RW access even if you didn't
# ask for that. Use this to fix the state.
sub db_maybe_rw {
    my $db = shift->{db};
    open(my $fh, "+<&", $db->fd) || croak "Could not dup db fileno: $!";
    my $flags = fcntl($fh, F_GETFL, 0) ||
        croak "Could not fcntl db handle: $!";
    $flags &= O_ACCMODE;
    return 0 if $flags == O_RDONLY;
    croak "Don't know how to handle a database opened in mode $flags" unless
        $flags == O_RDWR;
    bless $db, DB_RW;
    return 1;
}

sub db_check {
    my $access = shift;
    my $db = $access->{db};

    if (!$db->get(VERSION, my $version)) {
        croak("Wanted version ", DB_VERSION, " differs from current $version for ", $access->db_file) if $version ne DB_VERSION;
    } else {
        $db = $access->upgrade(1);