1: #!/usr/bin/perl
2: # Copyright (c) 1998 Robert Braddock. All rights reserved.
3: # This program is free software; you can redistribute it and/or
4: # modify it under the same terms as Perl itself.
6: package Hash::Layered;
7: use strict;
9: use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION $REVISION); BEGIN {
10: @ISA = qw( Exporter Tie::Hash );
11: @EXPORT = ();
12: @EXPORT_OK = ();
13: %EXPORT_TAGS = ();
14: $VERSION = 0.3;
15: $REVISION = q$Revision: 1.2 $;
16: }
17: use Tie::Hash;
18: use Exporter;
21: use Carp;
23: my $DEBUG = 0;
25: #Short hand for object data structure. You need to be able to expand these
26: #abbreviations to read the module source
27: my ($dls, #default layer state
28: $ldc, #layer data count (aka index of "current layer")
29: $ldl, #layer data list
30: # list( list(layer_sub_id, transparency, var_name...), ... )
31: # $dvs, #default variable state
32: $vvh, #variable value-stack hash
33: #hash{ var_name -> list(var1.layer_id,var1.value, ...) }
34: # $vdc, #variable data count
35: # $vdl, #variable data list
36: # # list( list(var_id,transparency) )
37: # $ilc, #_intervening_layer cache
38: $itr, #iterator data
39: $obj_size) = (0..20);
41: #Structure for Layer Data List elements
42: my ($ldl_subid, #index-unique part for id
43: $ldl_sem, #semantics state
44: $ldl_vars, #first variable name defined in this layer
45: #... rest of variable names defined at this layer
46: ) = (0..20);
48: #Structure for Intervening Layer Cache
49: #my ($ilc_valid, #is the cache valid
50: # $ilc_offset, #offset for looking up layers
51: # ) = (0..20);
53: #Structure for Variable Data List
54: #my ($vdl_id, #ID for variable
55: # $vdl_sem, #semantics state
56: # ) = (0..20);
59: #Used to set the semantics for the layering
60: my %Semantics = ('opaque'=>'opaque', 'obstruct'=>'opaque',
61: 'transparent'=>'transparent', 'flat'=>'transparent',
62: 'oneway'=>'oneway', 'protect'=>'oneway',
63: 'invisible'=>'invisible', 'hidden'=>'invisible',
64: 'biased'=>'biased', 'cascade'=>'biased',
65: 'default'=>'default');
67: sub whowasi { (caller(1))[3] . '()' }
68: sub trace { $DEBUG = @_ ? shift : 1 }
70: #note doesn't carry default state from created object
71: sub new {
72: my $proto = shift;
73: my $class = ref($proto) || $proto;
74: my $self;
75: my $realself = {};
76: tie %$realself, $class.'::_Internal';
77: $self = bless $realself, $class;
78: $self->push;
79: #warn "new: SELF:$self REAL:$realself HASH:$hash\n";
80: return $self;
81: }
82: sub new_alt {
83: my $proto = shift;
84: my $class = ref($proto) || $proto;
85: my $self;
86: my %hash;# = {}; #this seems critical to calling tied in methods
87: #my $realself =
88: tie %hash, $class.'::_Internal';
89: #$self = $hash;
90: $self = bless \%hash, $class;
91: $self->push;
92: #warn "new: SELF:$self REAL:$realself HASH:$hash\n";
93: return $self;
94: }
97: sub set_default {
98: carp &whowasi if $DEBUG;
99: my ($self,$state) = @_;
100: $self = tied %$self if ref($self) eq __PACKAGE__;
101: $state = lc $state;
102: #if ($^W) {
103: carp "'$state' not a valid default layer state"
104: unless (defined $state && defined $Semantics{$state} &&
105: $Semantics{$state} ne 'default');
106: #}
107: #clear cache
108: #$self->[$ilc]->[$ilc_valid] = 0;
109: #replace state
110: ($state, $self->[$dls]) = ($self->[$dls], $Semantics{$state});
111: warn "SEMANTICS:default $state => ".$self->[$dls]."\n" if $DEBUG;
112: return $state;
113: }
115: sub set_layer {
116: carp &whowasi if $DEBUG;
117: my ($self,$state,$layerid) = @_;
118: $self = tied %$self if ref($self) eq __PACKAGE__;
119: $state = lc $state;
120: #if ($^W) {
121: carp "'$state' not a valid layer state"
122: unless (defined $state && defined $Semantics{$state});
123: #}
124: my $l_data;
125: if (defined $layerid && $layerid ne '') {
126: $layerid =~ /^(\d+)/;
127: $l_data = $1;
128: $l_data = $self->[$ldl]->[$l_data] if defined $l_data;
129: croak "'$layerid' does not refer to a valid layer"
130: unless defined $l_data;
131: } else {
132: $layerid = $self->_id($self->[$ldc]);
133: $l_data = $self->[$ldl]->[$self->[$ldc]];
134: }
135: #clear cache
136: #$self->[$ilc]->[$ilc_valid] = 0;
137: #replace state
138: ($state, $l_data->[$ldl_sem]) = ($l_data->[$ldl_sem], $Semantics{$state});
139: warn "SEMANTICS:$layerid $state => ".$l_data->[$ldl_sem]."\n" if $DEBUG;
141: return $state;
142: }
144: sub set_key {
145: croak "set_key not implemented";
146: }
148: sub set_key_default {
149: croak "set_key_default not implemented";
150: }
152: #? with arg means set for that variable key
153: sub default_opaque {
154: carp &whowasi if $DEBUG;
155: my $self = shift;
156: return $self->set_default('opaque') if (@_ == 0);
157: return $self->set_key_default('opaque',@_);
158: }
159: sub default_obstruct {
160: carp &whowasi if $DEBUG;
161: my $self = shift;
162: return $self->set_default('opaque') if (@_ == 0);
163: return $self->set_key_default('opaque',@_);
164: }
165: sub default_transparent {
166: carp &whowasi if $DEBUG;
167: my $self = shift;
168: return $self->set_default('transparent') if (@_ == 0);
169: return $self->set_key_default('transparent',@_);
170: }
171: sub default_flat {
172: carp &whowasi if $DEBUG;
173: my $self = shift;
174: return $self->set_default('transparent') if (@_ == 0);
175: return $self->set_key_default('transparent',@_);
176: }
177: sub default_oneway {
178: carp &whowasi if $DEBUG;
179: my $self = shift;
180: return $self->set_default('oneway') if (@_ == 0);
181: return $self->set_key_default('oneway',@_);
182: }
183: sub default_protect {
184: carp &whowasi if $DEBUG;
185: my $self = shift;
186: return $self->set_default('oneway') if (@_ == 0);
187: return $self->set_key_default('oneway',@_);
188: }
189: sub default_biased {
190: carp &whowasi if $DEBUG;
191: my $self = shift;
192: return $self->set_default('biased') if (@_ == 0);
193: return $self->set_key_default('biased',@_);
194: }
195: sub default_cascade {
196: carp &whowasi if $DEBUG;
197: my $self = shift;
198: return $self->set_default('biased') if (@_ == 0);
199: return $self->set_key_default('biased',@_);
200: }
201: sub default_invisible {
202: carp &whowasi if $DEBUG;
203: my $self = shift;
204: return $self->set_default('invisible') if (@_ == 0);
205: return $self->set_key_default('invisible',@_);
206: }
207: sub default_hidden {
208: carp &whowasi if $DEBUG;
209: my $self = shift;
210: return $self->set_default('invisible') if (@_ == 0);
211: return $self->set_key_default('invisible',@_);
212: }
213: sub opaque {
214: carp &whowasi if $DEBUG;
215: my $self = shift;
216: return $self->set_layer('opaque') if (@_ == 0);
217: return $self->set_key('opaque',@_);
218: }
219: sub obstruct {
220: carp &whowasi if $DEBUG;
221: my $self = shift;
222: return $self->set_layer('opaque') if (@_ == 0);
223: return $self->set_key('opaque',@_);
224: }
225: sub oneway {
226: carp &whowasi if $DEBUG;
227: my $self = shift;
228: return $self->set_layer('oneway') if (@_ == 0);
229: return $self->set_key('oneway',@_);
230: }
231: sub protect {
232: carp &whowasi if $DEBUG;
233: my $self = shift;
234: return $self->set_layer('oneway') if (@_ == 0);
235: return $self->set_key('oneway',@_);
236: }
237: sub biased {
238: carp &whowasi if $DEBUG;
239: my $self = shift;
240: return $self->set_layer('biased') if (@_ == 0);
241: return $self->set_key('biased',@_);
242: }
243: sub cascade {
244: carp &whowasi if $DEBUG;
245: my $self = shift;
246: return $self->set_layer('biased') if (@_ == 0);
247: return $self->set_key('biased',@_);
248: }
249: sub transparent {
250: carp &whowasi if $DEBUG;
251: my $self = shift;
252: return $self->set_layer('transparent') if (@_ == 0);
253: return $self->set_key('transparent',@_);
254: }
255: sub flat {
256: carp &whowasi if $DEBUG;
257: my $self = shift;
258: return $self->set_layer('transparent') if (@_ == 0);
259: return $self->set_key('transparent',@_);
260: }
261: sub invisible {
262: carp &whowasi if $DEBUG;
263: my $self = shift;
264: return $self->set_layer('invisible') if (@_ == 0);
265: return $self->set_key('invisible',@_);
266: }
267: sub hidden {
268: carp &whowasi if $DEBUG;
269: my $self = shift;
270: return $self->set_layer('invisible') if (@_ == 0);
271: return $self->set_key('invisible',@_);
272: }
273: sub default {
274: carp &whowasi if $DEBUG;
275: my $self = shift;
276: return $self->set_layer('default') if (@_ == 0);
277: return $self->set_key('default',@_);
278: }
280: #change current layer to a parent
281: #sub reroute {
282: #
283: #}
285: sub id {
286: carp &whowasi if $DEBUG;
287: my $self = shift;
288: $self = tied %$self if ref($self) eq __PACKAGE__;
289: #my $layer = $self->[$ldc];
290: return $self->_id;
291: }
293: sub push {
294: carp &whowasi if $DEBUG;
295: my $self = shift;
296: $self = tied %$self if ref($self) eq __PACKAGE__;
297: my ($ref,$id);
298: my $l_contents = $self->[$ldc] += 1;
299: my $l_data = $self->[$ldl];
300: #clear cache
301: #$self->[$ilc]->[$ilc_valid] = 0;
302:
303: if ($l_contents > $#$l_data) {
304: push @$l_data, ['a','default'];
305: } else {
306: $ref = $$l_data[$l_contents];
307: $#$ref = 1;
308: ++$$ref[0];
309: $$ref[1] = 'default';
310: }
311: $id = $self->_id($l_contents); # . $l_data->[$l_contents]->[0];
312: warn "PUSH:new layer $id\n" if $DEBUG;
313: return $id;
314: }
316: sub pop {
317: carp &whowasi if $DEBUG;
318: my $self = shift;
319: $self = tied %$self if ref($self) eq __PACKAGE__;
320: my ($v_stack,$v_layer,$i,$key,$reqid,$curid);
321: my ($l_current,$l_data,$v_valhash) = @$self[$ldc,$ldl,$vvh];
322: $reqid = shift;
323: $curid = $self->_id($l_current); # . $l_data->[$l_current]->[0];
324: if (defined $reqid && $reqid ne '') {
325: croak "Attempted to pop layer '$reqid' while at layer '$curid'" unless $reqid eq $curid;
326: }
327: croak "Attempted to pop base layer" if $l_current == 0;
329: #clear cache
330: #$self->[$ilc]->[$ilc_valid] = 0;
332: warn "POP:remove layer $curid\n" if $DEBUG;
333: #need to delete variable stack entries too
334: $l_data = $$l_data[$l_current];
335: for (my $i = 2; $i < @$l_data; $i += 1) {
336: $key = $$l_data[$i];
337: $v_stack = $$v_valhash{$key};
338: if (!defined $v_stack || @$v_stack == 0) {
339: carp "SNH:pop:key '$key' in layer data list has empty stack";
340: next;
341: }
342: $v_layer = $$v_stack[$#$v_stack-1];
343: confess "SNH:pop:key '$key' in layer data list has most recent layer $v_layer" if $v_layer != $l_current;
344: #delete value from variable stack, delete empty stacks
345: if (($#$v_stack -= 2) < 0) {
346: delete $self->[$vvh]->{$key}; #could leak memory here?
347: }
348: }
349:
350: #leave structures for reuse
351: $self->[$ldc] -= 1;
352: return $curid;
353: }
355: sub shift {
356: carp &whowasi if $DEBUG;
357: my $self = CORE::shift;
358: croak __FILE__.": shift not implemented";
359: return undef;
360: }
362: sub unshift {
363: carp &whowasi if $DEBUG;
364: my $self = CORE::shift;
365: croak __FILE__.": unshift not implemented";
366: return undef;
367: }
370: ######################################################################
371: ######################################################################
373: package Hash::Layered::_Internal;
374: use strict;
376: use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION $REVISION); BEGIN {
377: @ISA = qw( Exporter Tie::Hash );
378: @EXPORT = ();
379: @EXPORT_OK = ();
380: %EXPORT_TAGS = ();
381: $VERSION = '0.1';
382: $REVISION = q$Revision: 1.2 $;
383: }
384: use Tie::Hash;
385: use Exporter;
387: use Carp;
389: sub whowasi { (caller(1))[3] . '('.(defined($_[0])?$_[0]:'').')' }
390: sub trace { $DEBUG = @_ ? shift : 1 }
392: #is there an opaque layer between the current and the target layer?
393: #returns the target layer unless a lower layer is opaque
394: #passing >1 in is_write indicates a new key operation
395: sub _intervening_layer {
396: my ($self,$targ_idx,$is_write) = @_;
397: $targ_idx = 0 if $targ_idx eq 'top';
398: my ($layer,$state,$def_state,$def_is_opaque,$def_is_invisible,$layer_idx,
399: $cache);
401: #cache no good unless is has separate caches for read/write. sheesh
402: #$layer_idx = $self->[$ldc];
403: #lookup target layer in cache, return that value if it exists
404: #$cache = $self->[$ilc];
405: #if ($cache->[$ilc_valid]) {
406: # $layer = $cache->[$targ_idx + $ilc_offset];
407: # return $layer if defined $layer;
408: #} else {
409: # @$cache = ();
410: # $cache->[$ilc_valid] = 1;
411: #}
413: $def_state = $self->[$dls];
414: $def_is_opaque = ( ($def_state eq 'opaque') ||
415: ($def_state eq 'oneway' && $is_write) ||
416: ($def_state eq 'biased' && $is_write > 1) );
417: $def_is_invisible = ($def_state eq 'invisible');
418: for ($layer_idx=$self->[$ldc];
419: $layer_idx > $targ_idx;
420: $layer_idx -= 1) {
421: $layer = $self->[$ldl]->[$layer_idx];
422: $state = $layer->[$ldl_sem];
423: next if ($state eq 'invisible' ||
424: $def_is_invisible && $state eq 'default');
425: last if ( ($state eq 'opaque')
426: || ( $def_is_opaque && ($state eq 'default') ) );
427: last if ($is_write &&
428: ( ($state eq 'oneway') ||
429: ( ($is_write > 1) && ($state eq 'biased') ) ) );
430: }
431: $layer_idx = $targ_idx if $layer_idx < $targ_idx;
432: #$cache->[$targ_idx + $ilc_offset] = $layer_idx;
433: return $layer_idx;
434: }
437: sub _id {
438: my $self = shift; my $l = shift;
439: $l = $self->[$ldc] unless defined $l;
440: return $l.$self->[$ldl]->[$l]->[0];
441: }
443: sub TIEHASH {
444: carp &whowasi if $DEBUG;
445: my $proto = shift;
446: my $class = ref($proto) || $proto;
447: my $self = ['' x $obj_size ];
448: @$self[$dls,$ldc,$ldl,$vvh] = ('biased',-1,[],{});
449: $$self[$itr] = [[],-1,0];
450: #$$self[$ldl]->[0] = ['a','default'];
451: #$self->push;
452: return bless $self,$class;
453: }
455: sub FETCH {
456: my $self = shift;
457: my $key = shift;
458: carp &whowasi($key) if $DEBUG;
459: my ($vstack,$var_layer,$var_data,$l);
460: #lookup variable data
461: $vstack = $self->[$vvh]->{$key};
462: return undef unless defined $vstack && @$vstack > 0;
463: ($var_layer,$var_data) = @$vstack[$#$vstack-1,$#$vstack];
464:
465: #check for opaque layer
466: $l = _intervening_layer($self,$var_layer,0);
467: warn "FETCH:at "._id($self).":from "._id($self,$l).":".$key."\n" if $DEBUG;
468: return undef if ($l != $var_layer);
469: #no check for opaque variable, since it would have to be on top
470: return $var_data;
471: }
473: #write: 1 =>
474: # 2 =>
476: sub STORE {
477: my $self = shift;
478: my $key = shift;
479: my $val = shift;
480: carp &whowasi($key) if $DEBUG;
481: my ($vstack,$targ_layer,$l_idx,$l_data);
482: #lookup variable data
483: $vstack = $self->[$vvh]->{$key};
484: if (!defined $vstack) {
485: $vstack = $self->[$vvh]->{$key} = [ ];
486: }
487:
488: if (@$vstack == 0) {
489: $targ_layer = -1;
490: $l_idx = _intervening_layer($self,'top',1);
491: } else {
492: $targ_layer = $$vstack[$#$vstack-1];
493: $l_idx = _intervening_layer($self,$targ_layer,1);
494: }
495: if ($l_idx != $targ_layer) {
496: #new hash entry
497: push @$vstack,('','');
498: $l_idx = _intervening_layer($self,$l_idx,2);
499: #add variable name to layer data list
500: $l_data = $self->[$ldl]->[$l_idx];
501: push @$l_data, $key;
502: }
503: warn "STORE:at "._id($self).":to "._id($self,$l_idx).":".$key."\n" if $DEBUG;
504: @$vstack[$#$vstack-1,$#$vstack] = ($l_idx,$val);
505: warn "[".join("][",@$vstack)."]\n" if $DEBUG;
506: }
508: #note: pop also does deletion
509: sub DELETE {
510: my $self = shift;
511: my $key = shift;
512: carp &whowasi($key) if $DEBUG;
513: #lookup variable data
514: #check for value or opaque layer
515: #delete value from that layer
516: my ($vstack,$targ_layer,$l_idx,$l_data,$i);
517: #lookup variable data
518: $vstack = $self->[$vvh]->{$key};
519: if (!defined $vstack || @$vstack == 0) {
520: return;
521: }
522:
523: $targ_layer = $$vstack[$#$vstack-1];
524: $l_idx = _intervening_layer($self,$targ_layer,1);
525:
526: if ($l_idx != $targ_layer) {
527: return;
528: }
529: #delete value from variable stack, delete empty stacks
530: if (($#$vstack -= 2) < 0) { #perl could leak memory here
531: delete $self->[$vvh]->{$key};
532: }
533: #TOTEST delete variable name from layer data list
534: $l_data = $self->[$ldl]->[$l_idx];
535: for ($i=2; $i < @$l_data; $i += 1) {
536: last if $$l_data[$i] eq $key;
537: }
538: confess "SNH: delete: key [$key] should be on layer $l_idx, but is not in current layer data list" if $i > $#$l_data;
539: $$l_data[$i] = $$l_data[$#$l_data];
540: $#$l_data -= 1;
541: }
543: sub EXISTS {
544: my $self = shift;
545: my $key = shift;
546: carp &whowasi($key) if $DEBUG;
547: my ($vstack,$var_layer,$var_data,$l);
548: #lookup variable data
549: $vstack = $self->[$vvh]->{$key};
550: return undef unless defined $vstack && @$vstack > 0;
551: ($var_layer,$var_data) = @$vstack[$#$vstack-1,$#$vstack];
552: #check for opaque layer
553: #no check for opaque variable, since it would have to be on top
554: $l = _intervening_layer($self,$var_layer,0);
555: return ($l == $var_layer);
556: }
558: sub FIRSTKEY {
559: carp &whowasi if $DEBUG;
560: my $self = shift;
561: my $iter = $$self[$itr];
562: $$iter[0] = [ keys %{ $$self[$vvh] } ];
563: $$iter[1] = -1;
564: $$iter[2] = _intervening_layer($self,'top',0);
565: return $self->NEXTKEY;
566: }
568: sub NEXTKEY {
569: carp &whowasi if $DEBUG;
570: my $self = shift;
571: my $prevkey = shift;
572: my $iter = $$self[$itr];
573: my ($vl,$i,$l,$k,$vstack,$var_layer,$var_data);
574: $vl = $$iter[0]; #var key list
575: $i = $$iter[1];
576: $l = $$iter[2];
577: #warn "[[@$vl]]:I[$i]:L[$l]\n";
578: while ($i < $#$vl) {
579: $i += 1;
580: $k = $vl->[$i]; #the key
581: $vstack = $self->[$vvh]->{$k};
582: if (defined $vstack && @$vstack > 0) {
583: ($var_layer,$var_data) = @$vstack[$#$vstack-1,$#$vstack];
584: #warn ":I[$i]:L[$l]:$var_layer,$var_data\n";
585: } else {
586: next;
587: }
588: last unless ($l > $var_layer);
589: }
590: $$iter[1] = $i;
591: if ($i >= @$vl) {
592: return ();
593: } else {
594: return ($k,$var_data);
595: }
596: }
598: sub CLEAR {
599: carp &whowasi if $DEBUG;
600: my $self = shift;
601: my ($var_vals,$op_layer,$k,$vstack,$src_layer);
602: $var_vals = $self->[$vvh];
603: $op_layer = _intervening_layer($self,'top',1);
604: foreach $k (keys %$var_vals) {
605: my ($vstack,$targ_layer,$l_idx);
606: #lookup variable data
607: $vstack = $var_vals->{$k};
608: next if (!defined $vstack || @$vstack == 0);
609: while ($op_layer <= ($src_layer = $$vstack[$#$vstack-1])) {
610: $#$vstack -= 2;
611: last if @$vstack == 0;
612: }
613: }
614: }
616: sub DESTROY {
617: carp &whowasi if $DEBUG;
618: }
620: 1;