/usr/local/CPAN/OurNet-BBS/OurNet/BBS/MAPLE3/ArticleGroup.pm
# $File: //depot/libOurNet/BBS/lib/OurNet/BBS/MAPLE3/ArticleGroup.pm $ $Author: autrijus $
# $Revision: #9 $ $Change: 4823 $ $DateTime: 2003/03/19 19:35:32 $
package OurNet::BBS::MAPLE3::ArticleGroup;
use open IN => ':raw', OUT => ':raw';
# hdrfile for the upper level hdr file holding metadata of this level
# idxfile for hdr of the deeper level that this articlegroup is holding.
use strict;
no warnings 'deprecated';
use fields qw/basepath board name dir hdrfile idxfile recno
bm readlevel postlevel mtime btime _ego _hash _array/;
use subs qw/readok writeok/;
use OurNet::BBS::Base (
'$packstring' => 'LLLZ32Z80Z50Z9Z73',
'$packsize' => 256,
'@packlist' => [qw/time xmode xid id author nick date title/],
);
use Date::Parse;
use Date::Format;
use constant GEM_FOLDER => 0x00010000;
use constant GEM_BOARD => 0x00020000;
use constant GEM_GOPHER => 0x00040000;
use constant GEM_HTTP => 0x00080000;
use constant GEM_EXTEND => 0x80000000;
use constant POST_DELETE => 0x0080;
my %chronos;
sub writeok {
my ($self, $user, $op, $param) = @_;
my $id = $user->id;
# as usual, SYSOP has full access.
return 1 if $user->has_perm('PERM_SYSOP');
# store/delete an arbitary article require bm permission in that board
return 1 if $self->bm =~ /^\b\Q$id\E\b$/ and (
$user->has_perm('PERM_BM') or $self->readlevel == -1
);
# only PUSH allowed now
return unless $op eq 'PUSH' or ($op eq 'STORE' and $param->[0] eq '');
# actually you can store your own article, no big deal
my $value = $param->[-1]; # 0 for PUSH, 1 for STORE
my $author = $value->{author};
return if $author and $author ne $id;
my $header = $value->{header};
return if $header and $header->{From} !~ /^\Q$id\E\b/;
return ($author or $header); # at least one of author bits must exist
}
sub readok {
my ($self, $user) = @_;
my $readlevel = $self->readlevel;
return ($user->has_perm('PERM_SYSOP') or $self->bm eq $user->id)
if $readlevel == -1; # mailbox
return (!$readlevel or $readlevel & $user->{userlevel});
}
sub stamp {
my $chrono = shift;
my $str = '';
for (1 .. 7) {
$str = ((0 .. 9,'A' .. 'V')[$chrono & 31]) . $str;
$chrono >>= 5;
}
return "A$str";
}
sub new_id {
my $self = shift;
my ($chrono, $file, $fname);
$file = "$self->{basepath}/$self->{board}";
unless (-e "$file/$self->{hdrfile}") {
open(my $HEADER, ">$file/$self->{hdrfile}")
or die "cannot create $file/$self->{hdrfile}";
close $HEADER;
}
no warnings 'uninitialized';
$chrono = time;
$chronos{$self->{board}} = $chrono if $chrono > $chronos{$self->{board}};
while (my $id = stamp($chrono)) {
$fname = join('/', $file, substr($id, -1), $id);
last unless -e $fname;
$chrono = ++$chronos{$self->{board}};
}
# make storage subdir if not exist
my $path = $1 if $fname =~ m|^(.+)/|;
mkdir $path unless -d $path;
open(my $BODY, ">$fname") or die "cannot open $fname";
close $BODY;
return $chrono;
}
sub refresh_id {
my ($self, $key) = @_;
if (defined $self->{idxfile}) {
my $file = "$self->{basepath}/$self->{board}/$self->{idxfile}";
$self->filestamp($file, 'btime');
}
my $file = "$self->{basepath}/$self->{board}/$self->{hdrfile}";
local $/ = \$packsize;
open(my $DIR, "<$file") or die "can't read DIR file $file: $!";
if (defined $self->{recno} and defined $self->{name}) {
seek $DIR, $packsize * $self->{recno}, 0;
@{$self->{_hash}}{@packlist} = unpack($packstring, <$DIR>);
if ($self->{_hash}{id} ne $self->{name}) {
undef $self->{recno};
seek $DIR, 0, 0;
}
}
unless (defined $self->{name} and defined $self->{recno}) {
no warnings 'uninitialized';
if (defined $self->{name}) { # seek for name
$self->{recno} = 0;
while (my $data = <$DIR>) {
@{$self->{_hash}}{@packlist} = unpack($packstring, $data);
last if ($self->{_hash}{id} eq $self->{name});
$self->{recno}++;
}
}
else { # append
seek $DIR, 0, 2;
$self->{name} = stamp($self->{_hash}{time} = $self->new_id);
$self->{idxfile} = substr($self->{name}, -1)."/$self->{name}";
$self->{recno} = (stat($DIR))[7] / $packsize; # filesize/packsize
}
my @localtime = localtime;
if ($self->{_hash}{id} ne $self->{name}) {
$self->{_hash}{id} = $self->{name};
$self->{_hash}{xmode} = GEM_FOLDER;
$self->{_hash}{date} ||= sprintf(
"%02d/%02d/%02d", substr($localtime[5], -2),
$localtime[4] + 1, $localtime[3]
);
$self->{_hash}{filemode} = 0;
open($DIR, "+>>$file")
or die "can't write DIR file for $self->{board}: $!";
print $DIR pack($packstring, @{$self->{_hash}}{@packlist});
close $DIR;
open($DIR, '>' . join(
'/', $self->{basepath}, $self->{board},
substr($self->{name}, -1), $self->{name}
)) or die "can't write BODY file for $self->{board}: $!";
close $DIR;
}
}
return 1;
}
sub FETCHSIZE {
my $self = $_[0]->ego;
my $file = "$self->{basepath}/$self->{board}/$self->{idxfile}";
return int((stat($file))[7] / $packsize);
}
# Fetch key: id savemode author date title filemode body
sub refresh_meta {
my ($self, $key, $flag) = @_;
no warnings 'uninitialized';
my $file = "$self->{basepath}/$self->{board}/$self->{idxfile}";
my $name;
goto &refresh_id if $self->contains($key);
$self->refresh_id if (!defined($key) and $self->{dir});
if ($key and $flag == HASH and $self->{dir} and substr($self->{dir}, 0, 1) ne '/') {
print "Looking at $self->{dir}\n";
no warnings 'uninitialized';
# hash key -- no recaching needed
return if $self->{_hash}{$key};
my $obj = $self->module(
$key =~ /^D\./ ? 'ArticleGroup' : 'Article'
)->new({
basepath => $self->{basepath},
board => $self->{board},
name => $key,
dir => "$self->{dir}/$self->{name}",
hdrfile => '.DIR',
});
$self->{_hash}{$key} = $self->{_array}[$obj->recno] = $obj;
return 1;
}
local $/ = \$packsize;
open(my $DIR, "<$file") or (warn "can't read DIR file for $file: $!", return);
my $size = int((stat($file))[7] / $packsize);
if (defined($key) and $flag == ARRAY) {
# out-of-bound check
die 'no such article' if $key < 0 or $key >= $size;
seek $DIR, $packsize * $key, 0;
return $self->_insert($key, scalar <$DIR>);
}
return if $self->filestamp($file);
# reload the whole articlegroup
$self->_insert($_, scalar <$DIR>) foreach (0 .. $size - 1);
return 1;
}
# insert the desires key based on packed data
sub _insert($$) {
my ($self, $key, $data) = @_;
my %entry;
@entry{@packlist} = unpack($packstring, $data);
my $name = $entry{id};
return if exists $self->{_hash}{$name}
and $self->{_hash}{$name} == $self->{_array}[$key];
no warnings 'uninitialized';
$self->{_hash}{$name} = $self->{_array}[$key] = (
$entry{xmode} & POST_DELETE
) ? undef : $self->module(
($entry{xmode} & GEM_FOLDER) ? 'ArticleGroup' : 'Article'
)->new({
board => $self->{board},
basepath => $self->{basepath},
name => $name,
hdrfile => $self->{idxfile},
recno => $key,
dir => "$self->{dir}/$self->{name}",
($entry{xmode} & GEM_FOLDER) ? (
idxfile => substr($entry{id}, -1) . "/$entry{id}"
) : (),
});
return 1;
}
sub STORE {
my ($self, $key, $value) = @_;
($self, my $flag) = @{${$self}};
no warnings 'uninitialized';
if ($flag == HASH) {
if ($self->contains($key)) {
$self->refresh($key, $flag);
$self->{_hash}{$key} = $value;
my $file = "$self->{basepath}/$self->{board}/$self->{hdrfile}";
open(my $DIR, "+<$file") or die "cannot open $file for writing";
seek $DIR, $packsize * $self->{recno}, 0;
print $DIR pack($packstring, @{$self->{_hash}}{@packlist});
close $DIR;
return 1;
}
# special case: hash without key becomes PUSH.
die 'arbitary storage of message-ids condered harmful.' if $key;
$key = $#{$self->{_array}} + 1;
$flag = ARRAY;
}
elsif (!$self->{_array}) {
$self->refresh_meta;
}
my $obj;
if (exists $self->{_array}[$key]) {
$obj = $self->{_array}[$key];
}
else {
$obj = $self->module('Article', $value)->new({
basepath => $self->{basepath},
board => $self->{board},
hdrfile => $self->{idxfile},
recno => $key,
});
}
my $is_group = ref($obj) =~ m|ArticleGroup|;
if ($is_group) {
$obj->refresh('id');
}
elsif ($value->{header}) {
# modern style
@{$value}{qw/author nick/} = ($1, $2)
if $value->{header}{From} =~ m/^\s*(.+?)\s*(?:\((.*)\))?$/g;
@{$value}{qw/author nick/} = ($2, $1)
if $value->{header}{From} =~ m/^\s*\"?(.*?)\"?\s*\<(.*)\>$/g;
$value->{date} = time2str(
'%y/%m/%d', str2time($value->{header}{Date})
) if $value->{header}{Date};
$value->{title} = $value->{header}{Subject};
}
else {
# traditional style
$value->{header} = {
From => $value->{author}.
(defined $self->{_hash}{nick}
? " ($self->{_hash}{nick})" : ''),
Subject => $value->{title},
}
}
$value->{board} = $value->{header}{Board} = $self->{board}
unless $is_group;
while (my ($k, $v) = each %{$value}) {
$obj->{$k} = $v unless $k eq 'body' or $k eq 'id';
};
$obj->{body} = $value->{body} if defined $value->{body};
$self->refresh($key, $flag);
$self->{mtime} = $obj->{time}; # not mtime, due to chrono-ahead.
}
sub EXISTS {
my ($self, $key) = @_;
$self = $self->ego;
return 1 if exists ($self->{_hash}{$key});
my $file = "$self->{basepath}/$self->{board}/$self->{name}/.DIR";
return if $self->filestamp($file, 'mtime', 1);
open(my $DIR, "<$file") or die "can't read DIR file $file: $!";
my $board;
foreach my $key (0 .. int((stat($file))[7] / $packsize) - 1) {
read $DIR, $board, $packsize;
return 1 if unpack('x12Z32x212', $board) eq $key;
}
close $DIR;
return;
}
1;