1# $File: //depot/libOurNet/BBS/lib/OurNet/BBS/Base.pm $ $Author: autrijus $
2# $Revision: #8 $ $Change: 3850 $ $DateTime: 2003/01/25 20:03:29 $
3
4package OurNet::BBS::Base;
5use 5.006;
6
7use strict;
8no warnings 'deprecated';
9
10use constant EGO    => 0; use constant FLAG  => 1;
11use constant HASH   => 1; use constant ARRAY => 2;
12use constant CODE   => 3; use constant GLOB  => 4;
13use constant TYPES  => [qw/_ego _hash _array _code _glob/];
14use constant SIGILS => [qw/$ % @ & */];
15
16require PerlIO if $] >= 5.008;
17
18# These magical hashes below holds all cached initvar constants:
19# = subrountines   as $RegSub{$glob}
20# = module imports as $RegMod{$glob}
21# = variables      as $RegVar{$class}{$sym}
22
23my (%RegVar, %RegSub, %RegMod);
24
25my %Packlists; # $packlist cache for contains()
26
27## Class Methods ######################################################
28# These methods expects a package name as their first argument.
29
30# constructor method; turn into an pseudo hash if _phash exists
31
32use constant CONSTRUCTOR => << '.';
33sub __PKG__::new {
34    my __PACKAGE__ $self = bless([\%{__PKG__::FIELDS}], '__PACKAGE__');
35
36#    eval {
37    if (ref($_[1])) {
38        # Passed in a single hashref -- assign it!
39	%{$self} = %{$_[1]};
40    }
41    else {
42        # Automagically fill in the fields.
43	$self->{$_} = $_[$self->[0]{$_}] foreach ((__KEYS__)[0 .. $#_-1]);
44    }
45#    };
46
47#    require Carp and Carp::confess($@) if $@;
48
49__TIE__
50    return $self->{_ego} = bless (\[$self, __OBJ__], '__PKG__');
51}
52
531;
54.
55
56# import does following things:
57# 1. set up @ISA.
58# 2. export type constants.
59# 3. set overload bits.
60# 4. install accessor methods.
61# 5. handle variable propagation.
62# 6. install the new() handler.
63
64require overload; # no import, please
65
66sub import {
67    my $class = shift;
68    my $pkg   = caller(0);
69
70    no strict 'refs';
71    no warnings 'once';
72
73    # in non-direct usage, only ournet client gets symbols and sigils.
74    my $is_client = ($pkg eq 'OurNet::BBS::Client' or $pkg eq 'OurNet::BBS::OurNet::BBS');
75    return unless $class eq __PACKAGE__ or $is_client;
76
77    *{"$pkg\::$_"} = \&{$_} foreach qw/EGO FLAG HASH ARRAY CODE GLOB/;
78    return *{"$pkg\::SIGILS"} = \&{SIGILS} if $is_client;
79
80    *{"$pkg\::ego"} = sub { ${$_[0]}->[0] };
81
82    push @{"$pkg\::ISA"}, $class;
83
84    my (@overload, $tie_eval, $obj_eval);
85    my $fields = \%{"$pkg\::FIELDS"};
86
87    foreach my $type (HASH .. GLOB) {
88	if (exists($fields->{TYPES->[$type]})) { # checks for _hash .. _glob
89	    my $sigil = SIGILS->[$type];
90
91	    push @overload, "$sigil\{}" => sub {
92		# use Carp; eval { ${$_[0]}->[$type] } || Carp::confess($@)
93		${$_[0]}->[$type]
94	    };
95
96	    if ($type == HASH or $type == ARRAY) {
97		$tie_eval = "tie my ${sigil}obj => '$pkg', ".
98		            "[\$self, $type];\n" . $tie_eval;
99		$obj_eval .= ", \\${sigil}obj";
100	    }
101	    elsif ($type == CODE) {
102		$tie_eval .= 'my $code = sub { $self->refresh(undef, CODE);'.
103			     '$self->{_code}(@_) };';
104		$obj_eval .= ', $code';
105	    }
106	    elsif ($type == GLOB) {
107		$tie_eval = 'my $glob = \$self->{_glob};' . $tie_eval;
108		$obj_eval .= ', $glob';
109	    }
110	}
111	else {
112	    $obj_eval .= ', undef';
113
114	}
115    }
116
117    $obj_eval =~ s/(?:, undef)+$//;
118
119    my $sub_new = CONSTRUCTOR;
120    my $keys = join(' ', sort {
121	$fields->{$a} <=> $fields->{$b}
122    } grep {
123	/^[^_]/
124    } keys(%{$fields}));
125
126    $sub_new =~ s/__TIE__/$tie_eval/g;
127    $sub_new =~ s/__OBJ__/$obj_eval/g;
128    $sub_new =~ s/__PKG__/$pkg/g;
129    $sub_new =~ s/__KEYS__/qw{$keys}/g;
130    $sub_new =~ s/__PACKAGE__/OurNet::BBS::Base/g;
131
132    unless (eval $sub_new) {
133	require Carp;
134	Carp::confess "$sub_new\n\n$@";
135    }
136
137    $pkg->overload::OVERLOAD(
138	@overload,
139	'""'   => sub { overload::AddrRef($_[0]) },
140	'0+'   => sub { 0 },
141	'bool' => sub { 1 },
142	'cmp' => sub { "$_[0]" cmp "$_[1]" },
143	'<=>' => sub { "$_[0]" cmp "$_[1]" }, # for completeness' sake
144    );
145
146    # install accessor methods
147    unless (UNIVERSAL::can($pkg, '__accessor')) {
148        foreach my $property (keys(%{"$pkg\::FIELDS"}), '__accessor') {
149            *{"$pkg\::$property"} = sub {
150                my $self = ${$_[0]}->[EGO];
151		$self->refresh_meta;
152                $self->{$property} = $_[1] if $#_;
153                return $self->{$property};
154            };
155        }
156    }
157
158    # my $backend = $1 if $pkg =~ m|^OurNet::BBS::([^:]+)|;
159    my $backend = substr($pkg, 13, index($pkg, ':', 14) - 13); # fast
160
161    my @defer; # delayed aliasing until variables are processed
162    foreach my $parent (@{"$pkg\::ISA"}) {
163        next if $parent eq __PACKAGE__; # Base won't use mutable variables
164
165        while (my ($sym, $ref) = each(%{"$parent\::"})) {
166	    push @defer, ($pkg, $sym, $ref);
167        }
168
169	unshift @_, @{$RegMod{$parent}} if ($RegMod{$parent});
170    }
171
172    while (my ($mod, $symref) = splice(@_, 0, 2)) {
173        if ($mod =~ m/^\w/) { # getvar from other modules
174	    push @{$RegMod{$pkg}}, $mod, $symref;
175
176            require "OurNet/BBS/$backend/$mod.pm";
177            $mod = "OurNet::BBS::$backend\::$mod";
178
179            foreach my $symref (@{$symref}) {
180                my ($ch, $sym) = CORE::unpack('a1a*', $symref);
181		die "can't import: $mod\::$sym" unless *{"$mod\::$sym"};
182
183		++$RegVar{$pkg}{$sym};
184
185                *{"$pkg\::$sym"} = (
186                    $ch eq '$' ? \${"$mod\::$sym"} :
187                    $ch eq '@' ? \@{"$mod\::$sym"} :
188                    $ch eq '%' ? \%{"$mod\::$sym"} :
189                    $ch eq '*' ? \*{"$mod\::$sym"} :
190                    $ch eq '&' ? \&{"$mod\::$sym"} : undef
191                );
192            }
193        }
194        else { # this module's own setvar
195            my ($ch, $sym) = CORE::unpack('a1a*', $mod);
196
197	    *{"$pkg\::$sym"} = ($ch eq '$') ? \$symref : $symref;
198	    ++$RegVar{$pkg}{$sym};
199        }
200    }
201
202    my @defer_sub; # further deferred subroutines that needs localizing
203    while (my ($pkg, $sym, $ref) = splice(@defer, 0, 3)) {
204	next if exists $RegVar{$pkg}{$sym} # already imported
205	     or *{"$pkg\::$sym"}{CODE}; # defined by use subs
206
207	if (defined(&{$ref})) {
208	    push @defer_sub, ($pkg, $sym, $ref);
209	    next;
210	}
211
212	next unless ($ref =~ /^\*(.+)::(.+)/)
213	        and exists $RegVar{$1}{$2};
214
215	*{"$pkg\::$sym"} = $ref;
216	++$RegVar{$pkg}{$sym};
217    }
218
219    # install per-package wrapper handlers for mutable variables
220    while (my ($pkg, $sym, $ref) = splice(@defer_sub, 0, 3)) {
221	my $ref = ($RegSub{$ref} || $ref);
222	next unless ($ref =~ /^\*(.+)::([^:]+)$/);
223	next if defined(&{"$pkg\::$sym"});
224
225	if (%{$RegVar{$pkg}}) {
226	    eval qq(
227		sub $pkg\::$sym {
228	    ) . join('',
229		map { qq(
230		    local *$1\::$_ = *$pkg\::$_;
231		)} (keys(%{$RegVar{$pkg}}))
232	    ) . qq(
233		    &{$ref}(\@_);
234		};
235	    );
236	}
237	else {
238	    *{"$pkg\::$sym"} = $ref;
239	};
240
241	$RegSub{"*$pkg\::$sym"} = $ref;
242    }
243
244    return unless $OurNet::BBS::Encoding;
245    *{"$pkg\::unpack"} = \&_unpack;
246    *{"$pkg\::pack"} = \&_pack;
247}
248
249sub _unpack {
250    require Encode;
251    return map Encode::decode($OurNet::BBS::Encoding => $_), CORE::unpack($_[0], $_[1]);
252}
253
254sub _pack {
255    require Encode;
256    return CORE::pack($_[0], map Encode::encode($OurNet::BBS::Encoding => $_), @_[1..$#_]);
257}
258
259## Instance Methods ###################################################
260# These methods expects a tied object as their first argument.
261
262# unties through an object to get back the true $self
263sub ego { $_[0] }
264
265# the all-important cache refresh instance method
266sub refresh {
267    my $self = shift;
268    my $ego;
269
270    ($self, $ego) = (ref($self) eq __PACKAGE__)
271	? ($self->{_ego}, $self)
272	: ($self, ${$self}->[EGO]);
273
274    no strict 'refs';
275
276    my $prefix = ref($self)."::refresh_";
277    my $method = $_[0] && defined(&{"$prefix$_[0]"})
278	? "$prefix$_[0]" : $prefix.'meta';
279
280    return $method->($ego, @_);
281}
282
283# opens access to connections via OurNet protocol
284sub daemonize {
285    require OurNet::BBS::Server;
286    OurNet::BBS::Server->daemonize(@_);
287}
288
289=begin comment
290
291# The following code doesn't work, because they always override.
292
293# permission checking; fall-back for undefined packages
294sub writeok {
295    my ($self, $user, $op, $argref) = @_;
296
297    print "warning: permission model for ".ref($self)." unimplemented.\n".
298          "         access forbidden for user ".$user->id().".\n"
299	if $OurNet::BBS::DEBUG;
300
301    return;
302}
303
304# ditto
305sub readok {
306    my ($self, $user, $op, $argref) = @_;
307
308    print "warning: permission model for ".ref($self)." unimplemented.\n".
309          "         access forbidden for user ".$user->id().".\n"
310	if $OurNet::BBS::DEBUG;
311
312    return;
313}
314
315=end comment
316=cut
317
318# clears internal memory; uses CLEAR instead
319sub purge {
320    $_[0]->ego->{_ego}->CLEAR;
321}
322
323# returns the BBS backend for the object
324sub backend {
325    my $backend = ref($_[0]);
326
327    $backend = ref($_[0]{_ego}) if $backend eq __PACKAGE__;
328    $backend = substr($backend, 13, index($backend, ':', 14) - 13); # fast
329    # $backend = $1 if $backend =~ m|^OurNet::BBS::(\w+)|;
330
331    return $backend;
332}
333
334# developer-friendly way to check files' timestamp for mtime fields
335sub filestamp {
336    my ($self, $file, $field, $check_only) = @_;
337    my $time = (stat($file))[9];
338
339    no warnings 'uninitialized';
340
341    return 1 if $self->{$field ||= 'mtime'} == $time;
342    $self->{$field} = $time unless $check_only;
343
344    return 0; # something changed
345}
346
347# developer-friendly way to check timestamp for mtime fields
348sub timestamp {
349    my ($self, $time, $field, $check_only) = @_;
350
351    no warnings 'uninitialized';
352
353    return 1 if $self->{$field ||= 'mtime'} == $time;
354    $self->{$field} = $time unless $check_only;
355
356    return 0; # something changed
357}
358
359# check if something's in packlist; packages don't contain undef
360sub contains {
361    my ($self, $key) = @_;
362    $self = $self->{_ego} if ref($self) eq __PACKAGE__;
363
364    no strict 'refs';
365    no warnings 'uninitialized';
366    # print "checking $key against $self: @{ref($self).'::packlist'}\n";
367
368    return (length($key) and index(
369        $Packlists{ref($self)} ||= " @{ref($self).'::packlist'} ",
370        " $key ",
371    ) > -1);
372}
373
374# loads a module: ($self, $backend, $module).
375sub fillmod {
376    my $self = $_[0];
377    $self =~ s|::|/|g;
378
379    require "$self/$_[1]/$_[2].pm";
380    return "$_[0]::$_[1]::$_[2]";
381}
382
383# create a new module and fills in arguments in the expected order
384sub fillin {
385    my ($self, $key, $class) = splice(@_, 0, 3);
386    return if defined($self->{_hash}{$key});
387
388    $self->{_hash}{$key} = OurNet::BBS->fillmod(
389	$self->{backend}, $class
390    )->new(@_);
391
392    return 1;
393}
394
395# returns the module in the same backend, or $val's package if supplied
396sub module {
397    my ($self, $mod, $val) = @_;
398
399    if ($val and UNIVERSAL::isa($val, 'UNIVERSAL')) {
400	my $pkg = ref($val);
401
402	if (UNIVERSAL::isa($val, 'HASH')) {
403	    # special case: somebody blessed a hash to put into STORE.
404	    bless $val, 'main'; # you want black magic?
405	    $_[2] = \%{$val};   # curse (unbless) it!
406	}
407
408	return $pkg;
409    }
410
411    my $backend = $self->backend;
412    require "OurNet/BBS/$backend/$mod.pm";
413    return "OurNet::BBS::$backend\::$mod";
414}
415
416# object serialization for OurNet::Server calls; does nothing otherwise
417sub SPAWN { return $_[0] }
418sub REF { return ref($_[0]) }
419sub KEYS { return keys(%{$_[0]}) }
420
421# XXX: Object injection
422sub INJECT {
423    my ($self, $code, @param) = @_;
424
425    if (UNIVERSAL::isa($code, 'CODE')) {
426	require B::Deparse;
427
428	my $deparse = B::Deparse->new(qw/-p -sT/);
429	$code = $deparse->coderef2text($code);
430	$code =~ s/^\s+use (?:strict|warnings)[^;\n]*;\n//m;
431    }
432
433    require Safe;
434    my $safe = Safe->new;
435    $safe->permit_only(qw{
436	:base_core padsv padav padhv padany rv2gv refgen srefgen ref gvsv gv gelem
437    });
438
439    my $result = $safe->reval("sub $code");
440    warn $@ if $@;
441
442    return sub { $result->($self, @_) };
443}
444
445## Tiescalar Accessors ################################################
446# XXX: Experimental: Globs only.
447
448sub TIESCALAR {
449    return bless(\$_[1], $_[0]);
450}
451
452## Tiearray Accessors #################################################
453# These methods expects a raw (untied) object as their first argument.
454
455# merged hasharray!
456sub TIEARRAY {
457    return bless(\$_[1], $_[0]);
458}
459
460sub FETCHSIZE {
461    my ($self, $key) = @_;
462    my ($ego, $flag) = @{${$self}};
463
464    $self->refresh(undef, ARRAY);
465
466    return scalar @{$ego->{_array} ||= []};
467}
468
469sub PUSH {
470    my $self = shift;
471    my $size = $self->FETCHSIZE;
472
473    foreach my $item (@_) {
474        $self->STORE($size++, $item);
475    }
476}
477
478## Tiehash Accessors ##################################################
479# These methods expects a raw (untied) object as their first argument.
480
481# the Tied Hash constructor method
482sub TIEHASH {
483    return bless(\$_[1], $_[0]);
484}
485
486# fetch accessesor
487sub FETCH {
488    my ($self, $key) = @_;
489    my ($ego, $flag) = @{${$self}};
490
491    $self->refresh($key, $flag);
492
493    return ($flag == HASH) ? $ego->{_hash}{$key} : $ego->{_array}[$key];
494}
495
496# fallback implementation to STORE
497sub STORE {
498    die "@_: STORE unimplemented";
499}
500
501# delete an element; calls its remove() subroutine to handle actual removal
502sub DELETE {
503    my ($self, $key) = @_;
504    my ($ego, $flag) = @{${$self}};
505
506    $self->refresh($key, $flag);
507
508    if ($flag == HASH) {
509	return unless exists $ego->{_hash}{$key};
510	$ego->{_hash}{$key}->ego->remove
511	    if UNIVERSAL::can($ego->{_hash}{$key}, 'ego');
512	return delete($ego->{_hash}{$key});
513    }
514    else {
515	return unless exists $ego->{_array}[$key];
516	$ego->{_array}[$key]->ego->remove
517	    if UNIVERSAL::can($ego->{_array}[$key], 'ego');
518	return delete($ego->{_array}[$key]);
519    }
520}
521
522# check for existence of a key.
523sub EXISTS {
524    my ($self, $key) = @_;
525    my ($ego, $flag) = @{${$self}};
526
527    $self->refresh($key, $flag);
528
529    return ($flag == HASH) ? exists $ego->{_hash}{$key}
530                           : exists $ego->{_array}[$key];
531}
532
533# iterator; this one merely uses 'scalar keys()'
534sub FIRSTKEY {
535    my $self = $_[0];
536    my $ego = ${$self}->[EGO];
537
538    $ego->refresh_meta(undef, HASH);
539
540    scalar keys (%{$ego->{_hash}});
541    return $self->NEXTKEY;
542}
543
544# ditto
545sub NEXTKEY {
546    my $self = $_[0];
547
548    return each %{${$self}->[EGO]->{_hash}};
549}
550
551# empties the cache, do not DELETE the objects themselves
552sub CLEAR {
553    my $self = ${$_[0]}->[EGO];
554
555    %{$self->{_hash}}  = () if (exists $self->{_hash});
556    @{$self->{_array}} = () if (exists $self->{_array});
557}
558
559# could care less
560sub DESTROY () {};
561sub UNTIE   () {};
562
563our $AUTOLOAD;
564
565sub AUTOLOAD {
566    my $action = substr($AUTOLOAD, (
567        (rindex($AUTOLOAD, ':') - 1) || return
568    ));
569
570    no strict 'refs';
571
572    *{$AUTOLOAD} = sub {
573	use Carp; confess ref($_[0]->{_ego}).$action
574	    unless defined &{ref($_[0]->{_ego}).$action};
575	goto &{ref($_[0]->{_ego}).$action}
576    };
577
578    goto &{$AUTOLOAD};
579}
580
5811;
582