File Coverage

blib/lib/Perlilog.pm
Criterion Covered Total %
statement 99 252 39.2
branch 17 96 17.7
condition 0 6 0.0
subroutine 22 32 68.7
pod 0 15 0.0
total 138 401 34.4


line stmt bran cond sub pod time code
1             #
2             # This file is part of the Perlilog project.
3             #
4             # Copyright (C) 2003, Eli Billauer
5             #
6             # This program is free software; you can redistribute it and/or modify
7             # it under the terms of the GNU General Public License as published by
8             # the Free Software Foundation; either version 2 of the License, or
9             # (at your option) any later version.
10             #
11             # This program is distributed in the hope that it will be useful,
12             # but WITHOUT ANY WARRANTY; without even the implied warranty of
13             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14             # GNU General Public License for more details.
15             #
16             # You should have received a copy of the GNU General Public License
17             # along with this program; if not, write to the Free Software
18             # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
19             #
20             # A copy of the license can be found in a file named "licence.txt", at the
21             # root directory of this project.
22             #
23              
24             require 5.004;
25 1     1   3869 use Perlilog::PLerror;
  1         2  
  1         57  
26             package Perlilog;
27 1     1   4 use Perlilog::PLerror;
  1         1  
  1         44  
28 1     1   3 use strict 'vars';
  1         1  
  1         89  
29              
30             BEGIN {
31 1     1   2 @Perlilog::warnings = ();
32 1         1 %Perlilog::classes = ();
33             $SIG{__WARN__} = sub {
34 0         0 my ($class) = ($_[0] =~ /unquoted string.*?\"(.*?)\".*may clash/i);
35 0 0       0 if (defined $class) {
36 0         0 push @Perlilog::warnings, $_[0];
37             } else {
38 0         0 warn ($_[0])
39             }
40 1         2080 };
41             }
42              
43             END {
44 1     1   6 $SIG{__WARN__} = sub {warn $_[0]; }; # Prevent an endless recursion
  0         0  
45 1         10 foreach (@Perlilog::warnings) {
46 0         0 my ($class) = ($_ =~ /unquoted string.*?\"(.*?)\".*may clash/i);
47             warn ($_)
48 0 0       0 unless (defined $Perlilog::classes{$class});
49             }
50             }
51              
52             # We use explicit package names rather than Perl 5.6.0's "our", so
53             # perl 5.004 won't yell at us.
54              
55             @Perlilog::ISA = (Exporter);
56             @Perlilog::EXPORT = qw[&init &override &underride &inherit &inheritdir &interface &interfaceclass
57             &constreset &definedclass &globalobj &execute];
58             $Perlilog::VERSION = '1.0';
59             $Perlilog::STARTTIME = localtime();
60              
61             $Perlilog::perlilogflag = 0;
62             $Perlilog::globalobject=();
63             $Perlilog::interface_rec = undef;
64             @Perlilog::interface_excuses = ();
65              
66             unless ($Perlilog::perlilogflag) {
67             $Perlilog::perlilogflag = 1; # Indicate that this clause has been run once
68             $Perlilog::errorcrawl='system';
69             $Perlilog::callbacksdepth = 0; # This indicates when callbacks are going on.
70             undef $Perlilog::wrong_flag;
71              
72             #For unloaded classes: Value is [classfile, parent class, first-given classname].
73             %Perlilog::classes = ('PL_hardroot', 1);
74             %Perlilog::objects = ();
75             @Perlilog::VARS=(undef, undef); # First two variables may be addressed accidentally
76             @Perlilog::EQVARS=(undef, undef); # The first two point to themselves.
77             @Perlilog::interface_classes = ();
78             $Perlilog::objectcounter = 0;
79            
80             {
81             my $home = $INC{'Perlilog.pm'};
82             ($home) = ($home =~ /^(.*)Perlilog\.pm$/);
83             blow("Failed to resolve Perlilog.pm's directory")
84             unless (defined $home);
85             $Perlilog::home = $home;
86             }
87              
88             $Perlilog::classhome = "${Perlilog::home}Perlilog/sysclasses/";
89             inherit('root',"${Perlilog::classhome}PLroot.pl",'PL_hardroot');
90             inherit('codegen',"${Perlilog::classhome}PLcodegen.pl",'root');
91             inherit('verilog',"${Perlilog::classhome}PLverilog.pl",'codegen');
92             inherit('global',"${Perlilog::classhome}PLglobal.pl",'codegen');
93             inherit('port',"${Perlilog::classhome}PLport.pl",'root');
94             inherit('interface',"${Perlilog::classhome}PLinterface.pl",'verilog');
95             inherit('site_init',"${Perlilog::classhome}site_init.pl",'PL_hardroot');
96             }
97              
98             sub init {
99 1     1 0 12 site_init -> init;
100             }
101             sub inherit {
102 18     18 0 89 my $class = shift;
103 18         13 my $file = shift;
104 18         11 my $papa = shift;
105              
106             puke("Attempt to create the already existing class \'$class\'\n")
107 18 50       27 if $Perlilog::classes{$class};
108              
109 18 50       22 puke("No parent class defined for \'$class\'\n")
110             unless (defined $papa);
111 18         27 $Perlilog::classes{$class} = [$file, $papa, $class];
112             # The following two lines are a Perl 5.8.0 bug workaround (early
113             # versions). Google "stash autoload" for why.
114 18         14 undef ${"${class}::Perlilog_dummy_variable"};
  18         57  
115 18         11 undef ${"${class}::Perlilog_dummy_variable"}; # No single use warning...
  18         21  
116 18         18 return 1;
117             }
118              
119             sub inheritdir {
120 0     0 0 0 my $dir = shift;
121 0         0 my $papa = shift;
122              
123 0         0 ($dir) = ($dir =~ /^(.*?)[\/\\]*$/); # Remove trailing slashes
124              
125 0 0       0 blow("Nonexistent directory \'$dir\'\n")
126             unless (-d $dir);
127              
128 0         0 do_inheritdir($dir, $papa);
129 0         0 return 1;
130             }
131              
132             sub do_inheritdir {
133 0     0 0 0 my $dir = shift;
134 0         0 my $papa = shift;
135              
136 0         0 ($dir) = ($dir =~ /^(.*?)[\/\\]*$/); # Remove trailing slashes
137              
138 0 0       0 return unless (opendir(DIR,$dir));
139 0         0 my @files=sort readdir(DIR);
140 0         0 closedir(DIR);
141 0         0 my @dirs = ();
142 0         0 my %newclasses = ();
143              
144 0         0 foreach my $file (@files) {
145 0 0 0     0 next if (($file eq '.') || ($file eq '..'));
146 0         0 my $thefile = $dir.'/'.$file;
147              
148 0 0       0 if (-d $thefile) {
149 0 0       0 next unless ($file =~ /^[a-zA-Z][a-zA-Z0-9_]*$/);
150 0         0 push @dirs, $file, $thefile;
151             } else {
152 0         0 my ($class) = ($file =~ /^([a-zA-Z][a-zA-Z0-9_]*)\.pl$/i);
153 0 0       0 next unless (defined $class);
154 0         0 $class = lc $class; # Lowercase the class
155             blow("inheritdir: Attempt to create the already existing class \'".$class.
156             "\' with \'$thefile\' (possibly symbolic link loop?)\n")
157 0 0       0 if ($Eobj::classes{$class});
158 0         0 inherit($class, $thefile, $papa);
159 0         0 $newclasses{$class} = 1;
160             }
161             }
162 0         0 while ($#dirs > 0) { # At least two entries...
163 0         0 my $newpapa = lc shift @dirs;
164 0         0 my $descend = shift @dirs;
165            
166             blow("inheritdir: Could not descend to directory \'$descend\' because there was no \'".
167             $newpapa.".pl\' file in directory \'$dir\'\n")
168 0 0       0 unless ($newclasses{$newpapa});
169 0         0 do_inheritdir($descend, $newpapa);
170             }
171             }
172              
173             sub override {
174 0     0 0 0 my $class = shift;
175 0         0 my $file = shift;
176 0         0 my $papa = shift;
177              
178 0 0       0 unless ($Perlilog::classes{$class}) {
179 0 0       0 return inherit($class, $file, $papa)
180             if defined ($papa);
181 0         0 puke("Tried to override nonexisting class \'$class\', and no alternative parent given\n");
182             }
183              
184             puke("Attempt to override class \'$class\' after it has been loaded\n")
185 0 0       0 unless ref($Perlilog::classes{$class});
186              
187             # Now create a new name for the previous class pointer
188              
189 0         0 my $newname=$class.'_PL_';
190 0         0 my $i=1;
191 0         0 while (defined $Perlilog::classes{$newname.$i}) {$i++;}
  0         0  
192 0         0 $newname=$newname.$i;
193            
194             # This is the operation of overriding
195              
196 0         0 $Perlilog::classes{$newname}=$Perlilog::classes{$class};
197 0         0 $Perlilog::classes{$class}=[$file, $newname, $class];
198              
199             # The following two lines are a Perl 5.8.0 bug workaround (early
200             # versions). Google "stash autoload" for why.
201 0         0 undef ${"${newname}::Perlilog_dummy_variable"};
  0         0  
202 0         0 undef ${"${newname}::Perlilog_dummy_variable"}; # No single use warning
  0         0  
203              
204 0         0 return 1;
205             }
206              
207             sub underride {
208 0     0 0 0 my $class = shift;
209 0         0 my $file = shift;
210              
211 0 0       0 unless ($Perlilog::classes{$class}) {
212 0         0 puke("Tried to underride a nonexisting class \'$class\'\n");
213             }
214              
215             puke("Attempt to underride class \'$class\' after it has been loaded\n")
216 0 0       0 unless ref($Perlilog::classes{$class});
217              
218             # Now create a new name for the previous class pointer
219              
220 0         0 my $newname=$class.'_PL_';
221 0         0 my $i=1;
222 0         0 while (defined $Perlilog::classes{$newname.$i}) {$i++;}
  0         0  
223 0         0 $newname=$newname.$i;
224            
225 0         0 my $victim = $class;
226              
227             # Now we look for the grandfather
228 0         0 SEARCH: while (1) {
229 0         0 my $parent = ${$Perlilog::classes{$victim}}[1];
  0         0  
230 0 0       0 if (${$Perlilog::classes{$parent}}[2] ne $class) { # Same family?
  0         0  
231 0         0 last SEARCH;
232             } else {
233 0         0 $victim = $parent; # Climb up the family tree
234             }
235             }
236             # This is the operation of parenting
237              
238 0         0 $Perlilog::classes{$newname}=[$file, ${$Perlilog::classes{$victim}}[1], $class];
  0         0  
239 0         0 ${$Perlilog::classes{$victim}}[1]=$newname;
  0         0  
240              
241             # The following two lines are a Perl 5.8.0 bug workaround (early
242             # versions). Google "stash autoload" for why.
243 0         0 undef ${"${newname}::Perlilog_dummy_variable"};
  0         0  
244 0         0 undef ${"${newname}::Perlilog_dummy_variable"}; # No single use warning.
  0         0  
245 0         0 return 1;
246             }
247              
248             #definedclass:
249             #0 - not defined, 1 - defined but not loaded, 2 - defined and loaded
250              
251             sub definedclass {
252 4     4 0 3 my $class = shift;
253 4         2 my $p = $Perlilog::classes{$class};
254 4 50       10 return 0 unless (defined $p);
255 4 50       10 return 1 if ref($p);
256 0         0 return 2;
257             }
258              
259             sub interfaceclass {
260 4     4 0 5 my $class = shift;
261 4 50       5 puke("The class \'$class\' is not defined, and hence cannot be declared as an interface class\n")
262             unless (definedclass($class));
263 4         6 push @Perlilog::interface_classes, $class;
264             }
265              
266             sub classload {
267 8     8 0 7 my ($class, $schwonz) = @_;
268 8         9 my $p = $Perlilog::classes{$class};
269 8         6 my $err;
270              
271 8 50       17 blow($schwonz."Attempt to use undeclared class \'$class\'\n")
272             unless (defined $p);
273              
274             # If $p isn't a reference, the class has been loaded.
275             # This trick allows recursive calls.
276 8 100       13 return 1 unless ref($p);
277              
278 5         5 $Perlilog::classes{$class} = 1;
279              
280 5         4 my ($file, $papa, $original) = @{$p};
  5         8  
281              
282 5         10 classload($papa, $schwonz); # Make sure parents are loaded
283              
284             # Now we create the package wrapping
285              
286 5         8 my $d = "package $class; use strict 'vars'; use Perlilog::PLerror;\n";
287 5         8 $d.='@'.$class."::ISA=qw[$papa];\n";
288              
289             # Registering MUST be the last line before the text itself,
290             # since the line number is recorded. Line count in error
291             # messages begin immediately after the line that registers.
292              
293 5         11 $d.="&Perlilog::PLerror::register(\'$file\');\n# line 1 \"$file\"\n";
294              
295 5 50       128 open (CLASSFILE, $file) ||
296             blow($schwonz."Failed to open resource file \'$file\' for class \'$class\'\n");
297 5         580 $d.=join("",);
298 5         71 close CLASSFILE;
299 1     1   5 eval($d);
  1     1   0  
  1     1   25  
  1     1   3  
  1     1   1  
  1     1   289  
  1     1   4  
  1     1   1  
  1     1   22  
  1     1   3  
  1         1  
  1         2576  
  1         4  
  1         1  
  1         23  
  1         3  
  1         1  
  1         1123  
  1         4  
  1         1  
  1         22  
  1         3  
  1         1  
  1         1363  
  1         4  
  1         1  
  1         23  
  1         3  
  1         1  
  1         97  
  5         335  
300 5 50       19 blow ($schwonz."Failed to load class \'$original\':\n $@")
301             if ($@);
302             }
303              
304             sub globalobj {
305 0 0   0 0 0 return $Perlilog::globalobject if (ref $Perlilog::globalobject);
306 0         0 puke("Global object was requested before init() was executed\n");
307             }
308              
309             sub constreset {
310 0     0 0 0 return globalobj()->constreset(@_);
311             }
312              
313             sub execute {
314 0     0 0 0 globalobj()->execute();
315             }
316              
317             sub interface {
318 0 0   0 0 0 puke("Attempt to call 'interface' from within an interface object (use intobjects instead)\n")
319             if (defined $Perlilog::interface_rec);
320              
321 0         0 my $g=globalobj();
322              
323             puke("interface() called with non-object item\n")
324 0 0       0 if (grep {not ($g->isobject($_))} @_);
  0         0  
325              
326 0         0 $Perlilog::interface_rec = globalobj->get('MAX_INTERFACE_REC');
327 0         0 @Perlilog::interface_excuses=();
328              
329 0         0 my @obj=intobjects(@_);
330              
331 0         0 undef $Perlilog::interface_rec;
332              
333 0 0       0 if (@obj) {
334 0         0 foreach (@obj) {
335 0         0 $_->sustain();
336             }
337 0         0 return $obj[0];
338             } else {
339 0         0 my $p;
340 0         0 my @names=();
341              
342 0         0 foreach $p (@_) {
343 0 0       0 if ($g->isobject($p)) {
344 0         0 push @names, $p->who();
345             } else {
346 0         0 push @names, "(Non-object item)";
347             }
348             }
349              
350 0         0 my $excuses = "";
351 0         0 chomp @Perlilog::interface_excuses;
352 0         0 foreach (@Perlilog::interface_excuses) {
353 0         0 $excuses.="$_\n";
354             }
355            
356 0 0       0 $excuses = "No adequate interface object found\n"
357             unless (length($excuses));
358              
359 0         0 wrong("Failed to interface between ports:\n".
360             join("\n", @names)."\n----------\n$excuses");
361 0         0 return undef;
362             }
363             }
364              
365             sub intobjects {
366 0 0   0 0 0 puke("intobjects should be called only from within interface classes\n")
367             unless (defined $Perlilog::interface_rec);
368 0 0       0 if ($Perlilog::interface_rec<0) {
369 0         0 fishy("Maximal interface object recursion (MAX_INTERFACE_REC) was reached. ".
370             "Are the interface objects registered in the wrong order, or is the design ".
371             "very complex?\n");
372 0         0 return ();
373             }
374 0         0 my $c;
375             my @obj;
376 0         0 $Perlilog::interface_rec--;
377            
378 0         0 foreach $c (@Perlilog::interface_classes) {
379 0         0 @obj = $c->attempt(@_);
380 0 0       0 if (@obj) {
381 0 0       0 if (globalobj()->isobject($obj[0])) {
382 0         0 $obj[0]->set('perlilog-ports-to-connect', @_);
383 0         0 last;
384             }
385 0 0 0     0 push @Perlilog::interface_excuses, "class $c: ".$obj[0]
386             if (defined ($obj[0]) && $obj[0]=~/[a-z]/i);
387 0         0 @obj=();
388             }
389             }
390 0         0 $Perlilog::interface_rec++;
391 0         0 return @obj;
392             }
393              
394             # This routine attempts to keep lines below 80 chrs/lines
395             sub linebreak {
396 0     0 0 0 my $data = shift;
397 0         0 my $extraindent = shift;
398              
399 0 0       0 $extraindent = '' unless (defined $extraindent);
400              
401 0         0 my @chunks = split("\n", $data);
402              
403 0         0 foreach (@chunks) {
404 0         0 my $realout = '';
405 0         0 while (1) { # Not forever. We'll break this in proper time
406 0 0       0 if (/^.{0,79}$/) { # The rest fits well...
407 0         0 $realout .= $_;
408 0         0 last;
409             }
410             # We try to break the line after a comma.
411 0         0 my ($x, $y) = (/^(.{50,78},)\s*(.*)$/);
412             # Didn't work? A whitespace is enough, then.
413 0 0       0 ($x, $y) = (/^(.{50,79})\s+(.*)$/)
414             unless (defined $x);
415             # Still didn't work? Break at first white space.
416 0 0       0 ($x, $y) = (/^(.{50,}?)\s+(.*)$/)
417             unless (defined $x);
418            
419             # THAT didn't work? Give up. Just dump it all out.
420 0 0       0 unless (defined $x) {
421 0         0 $realout .= $_;
422 0         0 last;
423             } else { # OK, we have a line split!
424 0         0 $realout .= $x."\n";
425 0         0 $_ = $extraindent.$y; # The rest, only indented.
426             }
427             }
428 0         0 $_ = $realout;
429             }
430 0         0 my $final = join("\n", @chunks);
431 0 0       0 $final .= "\n" if ($data =~ /\n$/);
432 0         0 return $final;
433             }
434              
435             # Just empty packages (used by PLroot).
436             package PL_hardroot;
437             package PL_settable;
438             package PL_const;
439              
440             # And now the magic of autoloading.
441             package UNIVERSAL;
442 1     1   5 use Perlilog::PLerror;
  1         1  
  1         287  
443             $UNIVERSAL::errorcrawl='skip';
444             %UNIVERSAL::blacklist=();
445              
446             sub AUTOLOAD {
447 6     6   16 my $class = shift;
448 6         5 my $method = $UNIVERSAL::AUTOLOAD;
449 6         14 my ($junk,$file,$line)=caller;
450 6         12 my $schwonz = "at $file line $line";
451 6 100       18 return undef if $method =~ /::SUPER::/;
452              
453 3         12 my ($package) = $method =~ /^(.*?)::/;
454 3         7 $method =~ s/.*:://;
455              
456 3         4 my $name = ref($class);
457              
458 3 50       7 return undef if ($method eq 'DESTROY');
459            
460 3 50       4 print "$class, $package\n" unless ($class eq $package);
461 3 50       6 puke("Undefined function/method \'$method\' $schwonz\n")
462             unless ($class eq $package);
463              
464 3 50       6 if ($name) {
465             # Forgive. This is not our class anyway...
466 0         0 return undef;
467             }
468              
469             # Now we protect ourselves against infinite recursion, should
470             # the classload call fail silently. This will happen if the
471             # first attempt to call a method in a class is to a
472             # method that isn't defined.
473             puke("Undefined method \'$method\' in class \'$class\' $schwonz\n")
474 3 50       5 if $UNIVERSAL::blacklist{$class};
475 3         3 $UNIVERSAL::blacklist{$class}=1;
476              
477 3         10 &Perlilog::classload($class,
478             "While trying to load class \'$class\' due to call ".
479             "of method \'$method\' $schwonz:\n");
480            
481             #Just loaded the new class? Let's use it!
482 3         233 return $class->$method(@_);
483             }
484              
485             # Now have the "defineclass" subroutine defined, so we can use it to
486             # generate bareword warnings for anything but a class name.
487              
488              
489              
490             1; # Return true
491              
492             __END__