File Coverage

blib/lib/Perlilog/sysclasses/PLroot.pl
Criterion Covered Total %
statement 75 340 22.0
branch 26 152 17.1
condition 3 18 16.6
subroutine 8 28 28.5
pod n/a
total 112 538 20.8


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             # Perlilog's basic root class
25             ${__PACKAGE__.'::errorcrawl'}='system';
26             #our $errorcrawl='system';
27             sub new {
28 3     3   2 my $this = shift;
29 3         17 my $self = $this->SUPER::new(@_);
30 3   33     10 my $class = ref($this) || $this;
31 3 50       7 $self = {} unless ref($self);
32 3         3 bless $self, $class;
33 3         11 $self->store_hash([], @_);
34 3 50       5 if (defined $Perlilog::interface_rec) {
35 0         0 my $name = $self->get('nick');
36 0 0       0 puke("New \'$class\' transient object created without the 'nick' property set\n")
37             unless (defined $name);
38 0 0       0 puke("New \'$class\' transient object created with illegal nick: \'$name\'\n")
39             unless ($name=~/^[a-zA-Z_]\w*$/);
40 0         0 $self -> set('perlilog-transient', 'transient');
41             } else {
42 3         10 my $name = $self->get('name');
43 3 50       4 puke("New \'$class\' object created without the 'name' property set\n")
44             unless (defined $name);
45 3 50       11 puke("New \'$class\' object created with illegal name: ".$self->prettyval($name)."\n")
46             unless ($name=~/^[a-zA-Z_]\w*$/);
47              
48             blow("New \'$class\' object created with an already occupied name: \'$name\'\n")
49 3 50       5 if (exists $Perlilog::objects{$name});
50 3         4 my $lc = lc($name);
51 3         5 foreach (keys %Perlilog::objects) {
52 3 50       6 blow("New \'$class\' object created with a name \'$name\' when \'$_\' is already in the system (only case difference)\n")
53             if (lc($_) eq $lc);
54             }
55 3         3 $Perlilog::objects{$name}=$self;
56 3         5 my $papa = $self->get('parent');
57 3 50       4 $self -> setparent($papa) if (ref($papa));
58             }
59 3         5 $self -> const('perlilog-object-count', $Perlilog::objectcounter++);
60 3         6 return $self;
61             }
62              
63             sub sustain {
64 0     0   0 my $self = shift;
65 0         0 my $name = $self->suggestname($self->get('nick'));
66 0         0 $self->const('name', $name);
67 0         0 $Perlilog::objects{$name}=$self;
68 0         0 $self -> set('perlilog-transient', 'sustained');
69 0         0 my $papa = $self->get('parent');
70 0 0       0 $self -> setparent($papa) if (ref($papa));
71             }
72              
73             sub who {
74 0     0   0 my $self = shift;
75 0         0 return "object \'".$self->get('name')."\'";
76             }
77              
78             sub safewho {
79 0     0   0 my ($self, $who) = @_;
80 0 0       0 return "(non-object item)" unless ($self->isobject($who));
81 0         0 return $who->who;
82             }
83              
84             sub isobject {
85 0     0   0 my ($self, $other) = @_;
86 0         0 my $r = ref $other;
87 0 0       0 return 1 if (Perlilog::definedclass($r) == 2);
88 0         0 return undef;
89             }
90              
91             sub objbyname {
92 0     0   0 my ($junk, $name) = @_;
93 0         0 return $Perlilog::objects{$name};
94             }
95              
96             sub suggestname {
97 0     0   0 my ($self, $name) = @_;
98 0         0 my $sug = $name;
99 0         0 my ($bulk, $num) = ($name =~ /^(.*)_(\d+)$/);
100 0         0 my %v;
101              
102 0         0 foreach (keys %Perlilog::objects) { $v{lc($_)}=1; } # Store lowercased names
  0         0  
103 0 0       0 unless (defined $bulk) {
104 0         0 $bulk = $name;
105 0         0 $num = 0;
106             }
107            
108 0         0 while ($v{lc($sug)}) {
109 0         0 $num++;
110 0         0 $sug = $bulk.'_'.$num;
111             }
112 0         0 return $sug;
113             }
114              
115             sub get {
116 8     8   4 my $self = shift;
117 8         6 my $prop = shift;
118 8         6 my $final;
119              
120 8 50       10 my @path = (ref($prop)) ? @{$prop} : ($prop);
  0         0  
121              
122 8         10 $final = $self->{join("\n", 'plPROP', @path)};
123              
124             # Now try to return it the right way. If we have a reference, then
125             # the property is set. So if the calling context wants an array, why
126             # hassle? Let's just give an array.
127             # But if a scalar is expected, and we happen to have only one
128             # member in the list -- let's be kind and give the first value
129             # as a scalar.
130              
131 8 100       12 if (ref($final)) {
132 5 100       6 return @{$final} if (wantarray);
  1         5  
133 4         2 return ${$final}[0];
  4         7  
134             }
135              
136             # We got here, so the property wasn't defined. Now, if
137             # we return an undef in an array context, it's no good, because it
138             # will be considered as a list with lenght 1. If the property
139             # wasn't defined we want to say "nothing" -- and that's an empty list.
140              
141 3 50       5 return () if (wantarray);
142              
143             # Wanted a scalar? Undef is all we can offer now.
144              
145 3         4 return undef;
146             }
147              
148             sub getraw {
149 19     19   11 my $self = shift;
150            
151 19         49 return $self->{join("\n", 'plPROP', @_)};
152             }
153              
154             sub store_hash {
155 3     3   3 my $self = shift;
156 3         2 my $rpath = shift;
157 3         3 my @path = @{$rpath};
  3         3  
158 3         7 my %h = @_;
159              
160 3         5 foreach (keys %h) {
161 4         4 my $val = $h{$_};
162              
163 4 50       9 if (ref($val) eq 'HASH') {
    50          
164 0         0 $self->store_hash([@path, $_], %{$val});
  0         0  
165             } elsif (ref($val) eq 'ARRAY') {
166 0         0 $self->const([@path, $_], @{$val});
  0         0  
167             } else {
168 4         9 $self->const([@path, $_], $val);
169             }
170             }
171             }
172              
173             sub const {
174 8     8   6 my $self = shift;
175 8         7 my $prop = shift;
176              
177 8 100       11 my @path = (ref($prop)) ? @{$prop} : ($prop);
  4         5  
178              
179 8         7 my @newval = @_;
180              
181 8         9 my $pre = $self->getraw(@path);
182              
183 8 50       8 if (defined($pre)) {
184 0 0       0 puke("Attempt to change a settable property into constant\n")
185             unless (ref($pre) eq 'PL_const');
186              
187 0         0 my @pre = @{$pre};
  0         0  
188              
189 0         0 my $areeq = ($#pre == $#newval);
190 0         0 my $i;
191 0         0 my $eq = $self->get(['plEQ',@path]);
192              
193 0 0       0 if (ref($eq) eq 'CODE') {
194 0         0 for ($i=0; $i<=$#pre; $i++) {
195 0 0       0 $areeq = 0 unless (&{$eq}($pre[$i], $newval[$i]));
  0         0  
196             }
197             } else {
198 0         0 for ($i=0; $i<=$#pre; $i++) {
199 0 0       0 $areeq = 0 unless ($pre[$i] eq $newval[$i]);
200             }
201             }
202              
203 0 0       0 unless ($areeq) {
204 0 0 0     0 if (($#path==2) && ($path[0] eq 'vars') && ($path[2] eq 'dim')) {
      0        
205             # This is dimension inconsintency. Will happen a lot to novices,
206             # and deserves a special error message.
207 0         0 wrong("Conflict in setting the size of variable \'$path[1]\' in ".
208             $self->who.". The conflicting values are ".
209             $self->prettyval(@pre)." and ".$self->prettyval(@newval).
210             ". (This usually happens as a result of connecting variables of".
211             " different sizes, possibly indirectly)\n");
212            
213            
214             } else {
215 0         0 { local $@; require Perlilog::PLerrsys; } # XXX fix require to not clear $@?
  0         0  
  0         0  
216 0         0 my ($at, $hint) = &Perlilog::PLerror::constdump();
217            
218 0         0 wrong("Attempt to change constant value of \'".
219             join(",",@path)."\' to another unequal value ".
220             "on ".$self->who." $at\n".
221             "Previous value was ".$self->prettyval(@pre).
222             " and the new value is ".$self->prettyval(@newval)."\n$hint\n");
223             }
224             }
225             } else {
226 8 50       13 if ($Perlilog::callbacksdepth) {
227 0         0 my $prop = join ",",@path;
228 0         0 my $who = $self->who;
229 0         0 hint("On $who: \'$prop\' = ".$self->prettyval(@newval)." due to magic property setting\n");
230             }
231 8         15 $self->domutate((bless \@newval, 'PL_const'), @path);
232              
233 8         9 my $cbref = $self->getraw('plMAGICS', @path);
234 8 50       33 return unless (ref($cbref) eq 'PL_settable');
235 0         0 my $subref;
236              
237 0         0 $Perlilog::callbacksdepth++;
238 0         0 while (ref($subref=shift @{$cbref}) eq 'CODE') {
  0         0  
239 0         0 &{$subref}($self, @path);
  0         0  
240             }
241 0         0 $Perlilog::callbacksdepth--;
242             }
243             }
244              
245             sub set {
246 3     3   3 my $self = shift;
247 3         3 my $prop = shift;
248              
249 3         1 my @path;
250 3 50       6 @path = (ref($prop)) ? @{$prop} : ($prop);
  0         0  
251              
252 3         3 my @newval = @_;
253              
254 3         4 my $pre = $self->getraw(@path);
255 3         3 my $ppp = ref($pre);
256 3 50 33     7 puke ("Attempted to set a constant property\n")
257             if ((defined $pre) && ($ppp ne 'PL_settable'));
258 3         5 $self->domutate((bless \@newval, 'PL_settable'), @path);
259 3         4 return 1;
260             }
261              
262             sub domutate {
263 11     11   6 my $self = shift;
264 11         7 my $newval = shift;
265 11         9 my $def = 0;
266 11 50 33     3 $def=1 if ((defined ${$newval}[0]) || ($#{$newval}>0));
  11         23  
  0         0  
267            
268 11 50       11 if ($def) {
269 11         17 $self->{join("\n", 'plPROP', @_)} = $newval;
270 0         0 } else { delete $self->{join("\n", 'plPROP', @_)}; }
271 11         9 return 1;
272             }
273              
274             sub seteq {
275 0     0   0 my $self = shift;
276 0         0 my $prop = shift;
277 0 0       0 my @path = (ref($prop)) ? @{$prop} : ($prop);
  0         0  
278 0         0 my $eq = shift;
279 0 0       0 puke("Callbacks should be references to subroutines\n")
280             unless (ref($eq) eq 'CODE');
281 0         0 $self->set(['plEQ', @path], $eq);
282             }
283              
284             sub addmagic {
285 0     0   0 my $self = shift;
286 0         0 my $prop = shift;
287 0 0       0 my @path = (ref($prop)) ? @{$prop} : ($prop);
  0         0  
288 0         0 my $callback = shift;
289              
290 0 0       0 unless (defined($self->get([@path]))) {
291 0         0 $self->punshift(['plMAGICS', @path], $callback);
292             } else {
293 0         0 $Perlilog::callbacksdepth++;
294 0         0 &{$callback}($self, @path);
  0         0  
295 0         0 $Perlilog::callbacksdepth--;
296             }
297             }
298              
299             sub registerobject {
300 1     1   1 my $self = shift;
301 1         1 my $phase = shift;
302 1 50       2 if (defined $phase) {
303 1 50       7 return undef if ($phase eq 'noreg');
304 0 0         return $self -> globalobj -> ppush('beginobjects', $self) if ($phase eq 'begin');
305 0 0         return $self -> globalobj -> ppush('endobjects', $self) if ($phase eq 'end');
306             }
307 0           return $self -> globalobj -> ppush('objects', $self);
308             }
309              
310             sub pshift {
311 0     0     my $self = shift;
312 0           my $prop = shift;
313 0 0         my @path = (ref($prop)) ? @{$prop} : ($prop);
  0            
314 0           my $pre = $self->getraw(@path);
315 0 0         if (ref($pre) eq 'PL_settable') {
316 0           return shift @{$pre};
  0            
317             } else {
318 0 0         return $self->set($prop, undef) # We're changing a constant property here. Will puke.
319             if (defined $pre);
320 0           return undef; # There was nothing there.
321             }
322             }
323              
324             sub ppop {
325 0     0     my $self = shift;
326 0           my $prop = shift;
327 0 0         my @path = (ref($prop)) ? @{$prop} : ($prop);
  0            
328 0           my $pre = $self->getraw(@path);
329 0 0         if (ref($pre) eq 'PL_settable') {
330 0           return pop @{$pre};
  0            
331             } else {
332 0 0         return $self->set($prop, undef) # We're changing a constant property here. Will puke.
333             if (defined $pre);
334 0           return undef; # There was nothing there.
335             }
336             }
337              
338             sub punshift {
339 0     0     my $self = shift;
340 0           my $prop = shift;
341 0 0         my @path = (ref($prop)) ? @{$prop} : ($prop);
  0            
342            
343 0           my @val = @_;
344              
345 0           my $pre = $self->getraw(@path);
346 0 0         if (ref($pre) eq 'PL_settable') {
347 0           unshift @{$pre}, @val;
  0            
348             } else {
349 0 0         $self->set(\@path, (defined($pre))? ($pre, @val) : @val);
350             }
351             }
352              
353             sub ppush {
354 0     0     my $self = shift;
355 0           my $prop = shift;
356 0 0         my @path = (ref($prop)) ? @{$prop} : ($prop);
  0            
357            
358 0           my @val = @_;
359              
360 0           my $pre = $self->getraw(@path);
361 0 0         if (ref($pre) eq 'PL_settable') {
362 0           push @{$pre}, @val;
  0            
363             } else {
364 0 0         $self->set(\@path, (defined($pre))? (@val, $pre) : @val);
365             }
366             }
367              
368             sub globalobj {
369 0     0     return &Perlilog::globalobj();
370             }
371              
372             sub setparent {
373 0     0     my ($self, $papa)=@_;
374 0 0         wrong("Can't add a child to a static object ".$papa->who()."\n")
375             if ($papa->get('static'));
376 0           $self->const('parent', $papa);
377 0           $papa->ppush('children',$self);
378             }
379              
380             sub linebreak {
381 0     0     my $self = shift;
382 0           return &Perlilog::linebreak(@_);
383             }
384              
385             sub objdump {
386 0     0     my $self = shift;
387 0           my @todump;
388              
389 0 0         unless (@_) {
390 0           @todump = sort {$Perlilog::objects{$a}->get('perlilog-object-count') <=>
391 0           $Perlilog::objects{$b}->get('perlilog-object-count')}
392             keys %Perlilog::objects;
393 0           @todump = map {$Perlilog::objects{$_}} @todump;
  0            
394             } else {
395 0           @todump = (@_);
396             }
397              
398 0           foreach my $obj (@todump) {
399 0 0         unless ($self->isobject($obj)) {
400 0           my $r = $Perlilog::objects{$obj};
401 0 0         if (defined $r) {
402 0           $obj = $r;
403             } else {
404 0           print "Unknown object specifier ".$self->prettyval($obj)."\n\n";
405 0           next;
406             }
407             }
408            
409 0           my @prefix = ();
410 0           print $self->linebreak($self->safewho($obj).", class=\'".ref($obj)."\':")."\n";
411 0           my $indent = ' ';
412 0           foreach my $prop (sort keys %$obj) {
413 0           my @path = split("\n", $prop);
414 0 0         shift @path if ($path[0] eq 'plPROP');
415 0           my $propname = pop @path;
416              
417             # Now we make sure that the @path will be exactly like @prefix
418             # First, we shorten @prefix if it's longer than @path, or if it
419             # has items that are unequal to @path.
420              
421 0           CHOP: while (1) {
422             # If @prefix is longer, no need to check -- we need chopping
423             # anyhow
424 0 0         unless ($#path < $#prefix) {
425 0           my $i;
426 0           my $last = 1;
427 0           for ($i=0; $i<=$#prefix; $i++) {
428 0 0         if ($prefix[$i] ne $path[$i]) {
429 0           $last = 0; last;
  0            
430             }
431             }
432 0 0         last CHOP if $last;
433             }
434 0           my $tokill = pop @prefix;
435 0           $indent = substr($indent, 0, -((length($tokill) + 3)));
436             }
437              
438 0           my $out = $indent;
439              
440             # And now we fill in the missing @path to @prefix
441 0           while ($#path > $#prefix) {
442 0           my $toadd = $path[$#prefix + 1];
443 0           push @prefix, $toadd;
444 0           $out .= "$toadd > ";
445 0           $toadd =~ s/./ /g; # Substitute any character with white space...
446 0           $indent .= "$toadd ";
447             }
448 0           $out .= "$propname=";
449              
450             # Now we pretty-print the value.
451 0           my $valref = $obj->{$prop};
452 0 0         my @val = (ref($valref)) ? @$valref : (undef);
453            
454 0           my $extraindent = $out;
455 0           $extraindent =~ s/./ /g;
456              
457 0           $out .= $self->prettyval(@val);
458              
459             # Finally, we do some linebreaking, so that the output will be neat
460 0           print $self->linebreak($out, $extraindent)."\n";
461             }
462 0           print "\n";
463             }
464             }
465              
466             sub prettyval {
467 0     0     my $self = shift;
468 0           my $MaxListToPrint = 4;
469 0           my $MaxStrLen = 40;
470              
471 0           my @a = @_; # @a will be manipulated. Get a local copy
472              
473 0 0         if (@a > $MaxListToPrint) {
474             # cap the length of $#a and set the last element to '...'
475 0           $#a = $MaxListToPrint;
476 0           $a[$#a] = "...";
477             }
478 0           for (@a) {
479             # set args to the string "undef" if undefined
480 0 0         $_ = "undef", next unless defined $_;
481 0 0         if (ref $_) {
482 0 0         if ($Perlilog::classes{ref($_)}) { # Is this a known object?
483 0           $_='{'.$_->who.'}'; # Get the object's pretty ID
484 0           next;
485             }
486             # force reference to string representation
487 0           $_ .= '';
488 0           s/'/\\'/g;
489             }
490             else {
491 0           s/'/\\'/g;
492             # terminate the string early with '...' if too long
493 0 0 0       substr($_,$MaxStrLen) = '...'
494             if $MaxStrLen and $MaxStrLen < length;
495             }
496             # 'quote' arg unless it looks like a number
497 0 0         $_ = "'$_'" unless /^-?[\d.]+$/;
498             # print high-end chars as 'M-'
499 0           s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
  0            
500             # print remaining control chars as ^
501 0           s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  0            
502             }
503            
504             # append 'all', 'the', 'data' to the $sub string
505 0 0         return ($#a != 0) ? '(' . join(', ', @a) . ')' : $a[0];
506             }
507              
508             # Notes about the treestudy function:
509             # 1. It can be rerun on a tree. It should be rerun direcly before
510             # the 'treehash' will be used and/or the tree integrity is
511             # a must.
512             # 2. It can be run on any object in the tree.
513             # 3. For each object, the path to the object itself will be via
514             # the father (and back).
515             # 4. If the functions returns (as opposed to puke()s), the tree's
516             # integrity is assured (no loops, proper parent-child cross refs).
517             # 5. If the function returns, we're sure that object references can
518             # be resolved with the name and %Perlilog::objects (regarding the
519             # objects in the tree).
520              
521             sub treestudy {
522 0     0     my $self = shift;
523 0           my %beenthere = ($self, 1);
524 0           my @beenlist = ($self);
525 0           my ($i, $next);
526              
527             # We now climb up to reach grandpa
528              
529 0           $i=$self;
530 0           while (defined ($next=$i->get('parent'))) {
531 0 0         puke($i->who." has a non-object registered as a parent\n")
532             unless $self->isobject($next);
533              
534             # If we've already been where we were just about to climb,
535             # we have a loop. Very bad.
536 0 0         if ($beenthere{$next}) {
537 0           my $err = "Corrupted object tree (parent references are cyclic)\n";
538 0           $err.="The path crawled was as follows: ";
539 0           $err.=join(" -> ",map {$self->safewho($_); } (@beenlist, $next));
  0            
540 0           puke("$err\n");
541             }
542             # Fine. Mark this point, and go on climbing.
543 0           $beenthere{$next}=1;
544 0           push @beenlist, $next;
545 0           $i=$next;
546             }
547              
548             # We now make calls to two recursive functions, that do the
549             # real job. $i is the reference to the grandpa now.
550              
551 0           $i->treecrawldown;
552 0           $i->treecrawlup;
553 0           return $i;
554             }
555              
556             # treecrawlup: The children tell parents who their children are
557              
558             sub treecrawldown {
559 0     0     my $self = shift;
560 0           my @children = $self -> get('children');
561 0           my ($child, $reflection); # Does this sound poetic to you?
562 0           my %treepath=();
563 0           my $n;
564              
565             # We now enrich our %treepath with everything that the
566             # children tell us that they have
567              
568 0           foreach $child (@children) {
569             # We begin with making sure that $child is in fact
570             # a recognized object
571 0 0         puke($self->who." has a non-object member registered as a child\n")
572             unless $self->isobject($child);
573              
574             # We check up that the child recognizes us as the
575             # parent. Except for the feelings involved, this check
576             # assures there are no loops.
577 0           $reflection = $child->get('parent');
578 0 0         unless ($reflection eq $self) { # Poetic again?
579 0           my ($s, $c, $r) = map {$self->safewho($_);} ($self, $child, $reflection);
  0            
580 0           my $err="Faulty parent-child relations: ";
581 0           $err.="$c is marked as a child of $s, ";
582 0           $err.="but $r is the parent of $c\n";
583 0           puke($err);
584             }
585              
586             # Now we make sure that we can use the object's name
587             # instead of a reference to it.
588              
589             puke($self->safewho($child)." is badly registered in the global object hash\n")
590 0 0         unless ($child eq $Perlilog::objects{$child->get('name')});
591              
592             # We're safe now... We fill %treepath so that the
593             # keys are those objects that we can reach, values
594             # are which object to go to reach them. We also
595             # add the direct way to the child.
596            
597 0           foreach ($child->get('name'), $child->treecrawldown) { # RECURSIVE CALL!
598 0           $treepath{$_} = $child;
599             }
600             }
601 0           $self->set('treepath', \%treepath);
602 0           return keys %treepath; # Tell our caller what we can reach.
603             }
604              
605             # treecrawlup - The children ask the parents what is above them
606             sub treecrawlup {
607 0     0     my $self = shift;
608 0           my @children = $self->get('children');
609 0           my $tpr = $self->get('treepath'); # Tree Path Reference
610 0           my $papa = $self->get('parent');
611 0           my @ups;
612             my $child;
613              
614             # If this object has a parent (true for all except the root
615             # object), we learn from it about objects we haven't seen yet.
616              
617 0 0         if (ref($papa)) {
618 0           @ups = ($papa->get('name'), keys %{$papa->get('treepath')});
  0            
619              
620             # If we didn't know about the object, we add it and point
621             # to papa. Note that papa has a pointer to us, so we add
622             # ourselves here too (intentional).
623             # I truly apologize for the "${$tpr}{$_}" thing. It really
624             # means "$treehash{$_}", where %treehash is exactly the one
625             # created in treecrawldown().
626            
627 0           foreach (@ups) {
628 0 0         ${$tpr}{$_} = $papa unless ref(${$tpr}{$_});
  0            
  0            
629             }
630             }
631             # Now we know about all objects in the tree and how to reach
632             # them. Let our children enjoy the same fun.
633              
634 0           foreach $child (@children) {
635 0           $child->treecrawlup;
636             }
637             }
638