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