Help-Site Computer Manuals
Software
Hardware
Programming
Networking
  Algorithms & Data Structures   Programming Languages   Revision Control
  Protocols
  Cameras   Computers   Displays   Keyboards & Mice   Motherboards   Networking   Printers & Scanners   Storage
  Windows   Linux & Unix   Mac

/var/sites/help-site.com/auto/tmp/CPAN/9677/OurNet-BBS-1.66/lib/OurNet/BBS/Base.pm

/var/sites/help-site.com/auto/tmp/CPAN/9677/OurNet-BBS-1.66/lib/OurNet/BBS/Base.pm

# clears internal memory; uses CLEAR instead sub purge { $_[0]->ego->{_ego}->CLEAR; }

# returns the BBS backend for the object sub backend { my $backend = ref($_[0]);


    $backend = ref($_[0]{_ego}) if $backend eq __PACKAGE__;

    $backend = substr($backend, 13, index($backend, ':', 14) - 13); # fast

    # $backend = $1 if $backend =~ m|^OurNet::BBS::(\w+)|;

    return $backend;

}

# developer-friendly way to check files' timestamp for mtime fields sub filestamp { my ($self, $file, $field, $check_only) = @_; my $time = (stat($file))[9];


    no warnings 'uninitialized';

    return 1 if $self->{$field ||= 'mtime'} == $time;

    $self->{$field} = $time unless $check_only;

    return 0; # something changed

}

# developer-friendly way to check timestamp for mtime fields sub timestamp { my ($self, $time, $field, $check_only) = @_;


    no warnings 'uninitialized';

    return 1 if $self->{$field ||= 'mtime'} == $time;

    $self->{$field} = $time unless $check_only;

    return 0; # something changed

}

# check if something's in packlist; packages don't contain undef sub contains { my ($self, $key) = @_; $self = $self->{_ego} if ref($self) eq __PACKAGE__;


    no strict 'refs';

    no warnings 'uninitialized';

    # print "checking $key against $self: @{ref($self).'::packlist'}\n";

    return (length($key) and index(

        $Packlists{ref($self)} ||= " @{ref($self).'::packlist'} ",

        " $key ",

    ) > -1);

}

# loads a module: ($self, $backend, $module). sub fillmod { my $self = $_[0]; $self =~ s|::|/|g;




    require "$self/$_[1]/$_[2].pm";

    return "$_[0]::$_[1]::$_[2]";

}

# create a new module and fills in arguments in the expected order sub fillin { my ($self, $key, $class) = splice(@_, 0, 3); return if defined($self->{_hash}{$key});


    $self->{_hash}{$key} = OurNet::BBS->fillmod(

        $self->{backend}, $class

    )->new(@_);

    return 1;

}

# returns the module in the same backend, or $val's package if supplied sub module { my ($self, $mod, $val) = @_;


    if ($val and UNIVERSAL::isa($val, 'UNIVERSAL')) {

        my $pkg = ref($val);

        if (UNIVERSAL::isa($val, 'HASH')) {

            # special case: somebody blessed a hash to put into STORE.

            bless $val, 'main'; # you want black magic?

            $_[2] = \%{$val};   # curse (unbless) it!

        }

        return $pkg;

    }

    my $backend = $self->backend;

    require "OurNet/BBS/$backend/$mod.pm";

    return "OurNet::BBS::$backend\::$mod";

}

# object serialization for OurNet::Server calls; does nothing otherwise sub SPAWN { return $_[0] } sub REF { return ref($_[0]) } sub KEYS { return keys(%{$_[0]}) }

# XXX: Object injection sub INJECT { my ($self, $code, @param) = @_;


    if (UNIVERSAL::isa($code, 'CODE')) {

        require B::Deparse;

        my $deparse = B::Deparse->new(qw/-p -sT/);

        $code = $deparse->coderef2text($code);

        $code =~ s/^\s+use (?:strict|warnings)[^;\n]*;\n//m;

    }

    require Safe;

    my $safe = Safe->new;

    $safe->permit_only(qw{

        :base_core padsv padav padhv padany rv2gv refgen srefgen ref gvsv gv gelem

    });

    my $result = $safe->reval("sub $code");

    warn $@ if $@;

    return sub { $result->($self, @_) };

}

## Tiescalar Accessors ################################################ # XXX: Experimental: Globs only.

sub TIESCALAR { return bless(\$_[1], $_[0]); }

## Tiearray Accessors ################################################# # These methods expects a raw (untied) object as their first argument.

# merged hasharray! sub TIEARRAY { return bless(\$_[1], $_[0]); }

sub FETCHSIZE { my ($self, $key) = @_; my ($ego, $flag) = @{${$self}};


    $self->refresh(undef, ARRAY);

    return scalar @{$ego->{_array} ||= []};

}

sub PUSH { my $self = shift; my $size = $self->FETCHSIZE;


    foreach my $item (@_) {

        $self->STORE($size++, $item);

    }

}

## Tiehash Accessors ################################################## # These methods expects a raw (untied) object as their first argument.

# the Tied Hash constructor method sub TIEHASH { return bless(\$_[1], $_[0]); }

# fetch accessesor sub FETCH { my ($self, $key) = @_; my ($ego, $flag) = @{${$self}};


    $self->refresh($key, $flag);

    return ($flag == HASH) ? $ego->{_hash}{$key} : $ego->{_array}[$key];

}

# fallback implementation to STORE sub STORE { die ``@_: STORE unimplemented''; }

# delete an element; calls its remove() subroutine to handle actual removal sub DELETE { my ($self, $key) = @_; my ($ego, $flag) = @{${$self}};


    $self->refresh($key, $flag);

    if ($flag == HASH) {

        return unless exists $ego->{_hash}{$key};

        $ego->{_hash}{$key}->ego->remove

            if UNIVERSAL::can($ego->{_hash}{$key}, 'ego');

        return delete($ego->{_hash}{$key});

    }

    else {

        return unless exists $ego->{_array}[$key];

        $ego->{_array}[$key]->ego->remove

            if UNIVERSAL::can($ego->{_array}[$key], 'ego');

        return delete($ego->{_array}[$key]);

    }

}

# check for existence of a key. sub EXISTS { my ($self, $key) = @_; my ($ego, $flag) = @{${$self}};


    $self->refresh($key, $flag);

    return ($flag == HASH) ? exists $ego->{_hash}{$key} 

                           : exists $ego->{_array}[$key];

}

# iterator; this one merely uses 'scalar keys()' sub FIRSTKEY { my $self = $_[0]; my $ego = ${$self}->[EGO];


    $ego->refresh_meta(undef, HASH);

    scalar keys (%{$ego->{_hash}});

    return $self->NEXTKEY;

}

# ditto sub NEXTKEY { my $self = $_[0];


    return each %{${$self}->[EGO]->{_hash}};

}

# empties the cache, do not DELETE the objects themselves sub CLEAR { my $self = ${$_[0]}->[EGO];


    %{$self->{_hash}}  = () if (exists $self->{_hash});

    @{$self->{_array}} = () if (exists $self->{_array});

}

# could care less sub DESTROY () {}; sub UNTIE () {};

our $AUTOLOAD;

sub AUTOLOAD { my $action = substr($AUTOLOAD, ( (rindex($AUTOLOAD, ':') - 1) || return ));


    no strict 'refs';

    *{$AUTOLOAD} = sub {

        use Carp; confess ref($_[0]->{_ego}).$action

            unless defined &{ref($_[0]->{_ego}).$action};

        goto &{ref($_[0]->{_ego}).$action}

    };

    goto &{$AUTOLOAD};

}



1;

Programminig
Wy
Wy
yW
Wy
Programming
Wy
Wy
Wy
Wy