File Coverage

blib/lib/Eobj.pm

Criterion	Covered	Total	%
statement	99	220	45.0
branch	14	76	18.4
condition	0	3	0.0
subroutine	21	30	70.0
pod	0	10	0.0
total	134	339	39.5

#
# This file is part of the Eobj project.
#
# Copyright (C) 2003, Eli Billauer
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# A copy of the license can be found in a file named "licence.txt", at the
# root directory of this project.
#

use Eobj::PLerror;
package Eobj;

use Eobj::PLerror;

use 5.004;
use strict 'vars';
use warnings;

require Exporter;


BEGIN {
  @Eobj::warnings = ();
  %Eobj::classes = ();
  $SIG{__WARN__} = sub {
    my ($class) = ($_[0] =~ /unquoted string.*?\"(.*?)\".*may clash/i);
    if (defined $class) {
      push @Eobj::warnings, $_[0];
    } else {
      warn ($_[0])
    }
  };
}

END {
  $SIG{__WARN__} = sub {warn $_[0]; }; # Prevent an endless recursion
  foreach (@Eobj::warnings) {
    my ($class) = ($_ =~ /unquoted string.*?\"(.*?)\".*may clash/i);
    warn ($_)
      unless (defined $Eobj::classes{$class});
  }

  # Now we destroy all objects in an orderly fashion...
  foreach (sort { $b->get('eobj-object-count') <=> $a->get('eobj-object-count') }
	   values %Eobj::objects) {
    $_->survivor();
    $_->destroy();
  }
}

# We use explicit package names rather than Perl 5.6.0's "our", so
# perl 5.004 won't yell at us.

@Eobj::ISA = qw[Exporter];
@Eobj::EXPORT = qw[&init &override &underride &inherit &inheritdir &definedclass &globalobj];
$Eobj::VERSION = '0.23';
$Eobj::STARTTIME = localtime();

$Eobj::eobjflag = 0;
$Eobj::globalobject=();

unless ($Eobj::eobjflag) {
  $Eobj::eobjflag = 1; # Indicate that this clause has been run once
  $Eobj::errorcrawl='system';
  $Eobj::callbacksdepth = 0; # This indicates when callbacks are going on.
  undef $Eobj::wrong_flag;

  #For unloaded classes: Value is [classfile, parent class, first-given classname].
  %Eobj::classes = ('PL_hardroot', 1);
  %Eobj::objects = ();
  $Eobj::objectcounter = 0;

  {
    my $home = $INC{'Eobj.pm'};
    ($home) = ($home =~ /^(.*)Eobj\.pm$/);
    blow("Failed to resolve Eobj.pm's directory")
      unless (defined $home);
    $Eobj::home = $home;
  }

  $Eobj::classhome = "${Eobj::home}Eobj/";
  inherit('root',"${Eobj::classhome}PLroot.pl",'PL_hardroot');
  inherit('global',"${Eobj::classhome}PLglobal.pl",'root');
  inherit('site_init',"${Eobj::classhome}site_init.pl",'PL_hardroot');
}

sub init {
  site_init -> init;
}
sub inherit {
  my $class = shift;
  my $file = shift;
  my $papa = shift;

  puke("Attempt to create the already existing class \'$class\'\n")
    if $Eobj::classes{$class};

  puke("No parent class defined for \'$class\'\n")
    unless (defined $papa);
  $Eobj::classes{$class} = [$file, $papa, $class];
  # The following two lines are a Perl 5.8.0 bug workaround (early
  # versions). Google "stash autoload" for why.
  undef ${"${class}::Eobj_dummy_variable"};
  undef ${"${class}::Eobj_dummy_variable"}; # No single use warning...
  return 1;
}

sub inheritdir {
  my $dir = shift;
  my $papa = shift;

  ($dir) = ($dir =~ /^(.*?)[\/\\]*$/); # Remove trailing slashes

  blow("Nonexistent directory \'$dir\'\n")
    unless (-d $dir);

  do_inheritdir($dir, $papa);
  return 1;
}

sub do_inheritdir {
  my $dir = shift;
  my $papa = shift;

  ($dir) = ($dir =~ /^(.*?)[\/\\]*$/); # Remove trailing slashes

  return unless (opendir(DIR,$dir));
  my @files=sort readdir(DIR);
  closedir(DIR);
  my @dirs = ();
  my %newclasses = ();

  foreach my $file (@files) {
    next if (($file eq '.') || ($file eq '..'));
    my $thefile = $dir.'/'.$file;

    if (-d $thefile) {
      next unless ($file =~ /^[a-zA-Z][a-zA-Z0-9_]*$/);
      push @dirs, $file, $thefile;
    } else {
      my ($class) = ($file =~ /^([a-zA-Z][a-zA-Z0-9_]*)\.pl$/i);
      next unless (defined $class);
      $class = lc $class; # Lowercase the class
      blow("inheritdir: Attempt to create the already existing class \'".$class.
	   "\' with \'$thefile\' (possibly symbolic link loop?)\n")
	if ($Eobj::classes{$class});
      inherit($class, $thefile, $papa);
      $newclasses{$class} = 1;
    }
  }
  while ($#dirs > 0) { # At least two entries...
    my $newpapa = lc shift @dirs;
    my $descend = shift @dirs;

    blow("inheritdir: Could not descend to directory \'$descend\' because there was no \'".
	 $newpapa.".pl\' file in directory \'$dir\'\n")
      unless ($newclasses{$newpapa});
    do_inheritdir($descend, $newpapa);
  }
}

sub override {
  my $class = shift;
  my $file = shift;
  my $papa = shift;

  unless ($Eobj::classes{$class}) {
    return inherit($class, $file, $papa)
      if defined ($papa);
    puke("Tried to override nonexisting class \'$class\', and no alternative parent given\n");
  }

  puke("Attempt to override class \'$class\' after it has been loaded\n")
    unless ref($Eobj::classes{$class});

  # Now create a new name for the previous class pointer

  my $newname=$class.'_PL_';
  my $i=1;
  while (defined $Eobj::classes{$newname.$i}) {$i++;}
  $newname=$newname.$i;

  # This is the operation of overriding

  $Eobj::classes{$newname}=$Eobj::classes{$class};
  $Eobj::classes{$class}=[$file, $newname, $class];

  # The following two lines are a Perl 5.8.0 bug workaround (early
  # versions). Google "stash autoload" for why.
  undef ${"${newname}::Eobj_dummy_variable"};
  undef ${"${newname}::Eobj_dummy_variable"}; # No single use warning

  return 1;
}

sub underride {
  my $class = shift;
  my $file = shift;

  unless ($Eobj::classes{$class}) {
    puke("Tried to underride a nonexisting class \'$class\'\n");
  }

  puke("Attempt to underride class \'$class\' after it has been loaded\n")
    unless ref($Eobj::classes{$class});

  # Now create a new name for the previous class pointer

  my $newname=$class.'_PL_';
  my $i=1;
  while (defined $Eobj::classes{$newname.$i}) {$i++;}
  $newname=$newname.$i;

  my $victim = $class;

 # Now we look for the grandfather
 SEARCH: while (1) {
    my $parent = ${$Eobj::classes{$victim}}[1];
    if (${$Eobj::classes{$parent}}[2] ne $class) { # Same family?
      last SEARCH;
    } else {
      $victim = $parent; # Climb up the family tree
    }
  }
  # This is the operation of parenting

  $Eobj::classes{$newname}=[$file, ${$Eobj::classes{$victim}}[1], $class];
  ${$Eobj::classes{$victim}}[1]=$newname;

  # The following two lines are a Perl 5.8.0 bug workaround (early
  # versions). Google "stash autoload" for why.
  undef ${"${newname}::Eobj_dummy_variable"};
  undef ${"${newname}::Eobj_dummy_variable"}; # No single use warning.
  return 1;
}

#definedclass:
#0 - not defined, 1 - defined but not loaded, 2 - defined and loaded

sub definedclass {
  my $class = shift;
  my $p = $Eobj::classes{$class};
  return 0 unless (defined $p);
  return 1 if ref($p);
  return 2;
}

sub classload {
  my ($class, $schwonz) = @_;
  my $p = $Eobj::classes{$class};
  my $err;

  blow($schwonz."Attempt to use undeclared class \'$class\'\n")
    unless (defined $p);

  # If $p isn't a reference, the class has been loaded.
  # This trick allows recursive calls.
  return 1 unless ref($p);

  $Eobj::classes{$class} = 1;

  my ($file, $papa, $original) = @{$p};

  classload($papa, $schwonz); # Make sure parents are loaded

  # Now we create the package wrapping

  my $d = "package $class; use strict 'vars'; use Eobj::PLerror;\n";
  $d.='@'.$class."::ISA=qw[$papa];\n";

  # Registering MUST be the last line before the text itself,
  # since the line number is recorded. Line count in error
  # messages begin immediately after the line that registers.

  $d.="&Eobj::PLerror::register(\'$file\');\n# line 1 \"$file\"\n";

  open (CLASSFILE, $file) ||
    blow($schwonz."Failed to open resource file \'$file\' for class \'$class\'\n");
  $d.=join("",);
  close CLASSFILE;
  eval($d);
  blow ($schwonz."Failed to load class \'$original\':\n $@")
    if ($@);
}

sub globalobj {
  return $Eobj::globalobject if (ref $Eobj::globalobject);
  puke("Global object was requested before init() was executed\n");
}

# This routine attempts to keep lines below 80 chrs/lines
sub linebreak {
  my $data = shift;
  my $extraindent = shift;

  $extraindent = '' unless (defined $extraindent);

  my @chunks = split("\n", $data);

  foreach (@chunks) {
    my $realout = '';
    while (1) { # Not forever. We'll break this in proper time
      if (/^.{0,79}$/) { # The rest fits well...
	$realout .= $_;
	last;
      }
      # We try to break the line after a comma.
      my ($x, $y) = (/^(.{50,78},)\s*(.*)$/);
      # Didn't work? A whitespace is enough, then.
      ($x, $y) = (/^(.{50,79})\s+(.*)$/)
	unless (defined $x);
      # Still didn't work? Break at first white space.
      ($x, $y) = (/^(.{50,}?)\s+(.*)$/)
	unless (defined $x);

      # THAT didn't work? Give up. Just dump it all out.
      unless (defined $x) {
	$realout .= $_;
	last;
      } else { # OK, we have a line split!
	$realout .= $x."\n";
	$_ = $extraindent.$y; # The rest, only indented.
      }
    }
    $_ = $realout;
  }
  my $final = join("\n", @chunks);
  $final .= "\n" if ($data =~ /\n$/);
  return $final;
}

# Just empty packages (used by PLroot).
package PL_hardroot;
package PL_settable;
package PL_const;
package PL_destroyed;
use Eobj::PLerror;
# Here we yell on all attempts to run a method on a destroyed
# object. Only calling destroy is OK...
$PL_destroyed::errorcrawl='system';

sub destroy {
  return undef;
}

sub AUTOLOAD {
  my $class = shift;
  my $method = $PL_destroyed::AUTOLOAD;
  my ($package) = $method =~ /^(.*?)::/;
  $method =~ s/.*:://;

  return undef if ($method eq 'DESTROY');

  blow("Attempt to call method \'$method\' on a destroyed object\n");
}

# And now the magic of autoloading.
package UNIVERSAL;
use Eobj::PLerror;
$UNIVERSAL::errorcrawl='skip';
%UNIVERSAL::blacklist=();

sub AUTOLOAD {
  my $class = shift;
  my $method = $UNIVERSAL::AUTOLOAD;
  my ($junk,$file,$line)=caller;
  my $schwonz = "at $file line $line";
  return undef if $method =~ /::SUPER::/;

  my ($package) = $method =~ /^(.*?)::/;
  $method =~ s/.*:://;

  my $name = ref($class);

  return undef if ($method eq 'DESTROY');

  print "$class, $package\n"  unless ($class eq $package);
  puke("Undefined function/method \'$method\' $schwonz\n")
    unless ($class eq $package);

  if ($name) {
    # Forgive. This is not our class anyway...
    return undef;
  }

  # Now we protect ourselves against infinite recursion, should
  # the classload call fail silently. This will happen if the
  # first attempt to call a method in a class is to a
  # method that isn't defined.
  puke("Undefined method \'$method\' in class \'$class\' $schwonz\n")
    if $UNIVERSAL::blacklist{$class};
  $UNIVERSAL::blacklist{$class}=1;

  &Eobj::classload($class,
		       "While trying to load class \'$class\' due to call ".
		       "of method \'$method\' $schwonz:\n");

  #Just loaded the new class? Let's use it!
  return $class->$method(@_);
}

# Now have the "defineclass" subroutine defined, so we can use it to
# generate bareword warnings for anything but a class name.



1; # Return true
__END__