view release on metacpan or  search on metacpan

Iterator.pm  view on Meta::CPAN

		$me->{'contexts'}	= {};
		$me->{'err'}		= undef;

		return $me;
	}


	# setzt/liefert Objekt-Config: 	$obj->cfg()
	#				Modul-Config:	&Iterator::cfg()
	# rein:	- 1. (Key3, Key1=>Val1, Key2=>Val2 [, ...])
	#		- 2. nix
	# raus:	- 1. die alten Werte der übergebenen Keys
	#		- 2. %Objekt/Modul-Config
	# !! Es wird kein Validitätstest durchgeführt !!
	sub cfg {
		my ($me, $target, $key, $val, @cfg, @r);
		unless (ref $_[0] ){ 	# nicht als Methode gerufen
			$target	= \%_cfg;
		}else{					# ok, cfg des Objektes handlen
			$me		= shift;
			$target	= $me->{'_cfg'};
		}

		scalar @_	? do {shift @_ if $_[0] =~ /::/; 		# Parameter, also resp. cfg dotieren
					   return keys %{$target->{'_set_'}} if $_[0] eq '-Keys';
					   @cfg = @_}
					: return (%{$target->{'_set_'}});	# man will lesen, also % liefern

		while (@cfg) {
			$key = shift @cfg;
			push (@r, $target->{'_set_'}{$key});
			last unless @cfg;

			next if (defined $cfg[0] && exists $target->{'_set_'}{$cfg[0]});
			if ($key eq '-DigLevel') {
				$target->{'_set_'}{'-DigLevel'} = shift @cfg;
				$target->{'_set_'}{'-DigLevel'} = undef if $target->{'_set_'}{'-DigLevel'} eq '';
				next;
			}
			$target->{'_set_'}{$key} = shift (@cfg) ? 1 : 0
				if exists $target->{'_set_'}{$key};
		}
		$target->{'_init_'}->($target);
		return @r;
	}

	sub element {

		my $me 			= shift;
		$me->{'err'}	= undef;
		my ($type, $ob, $cb, $stack, $seen, $key, $vparent, $err);
		my $append		= 1;
		my $context		= $_[0];

		# Kontext (pfadabhängig) setzen...
		($stack, $seen, $context) = ($me->_get_context($context))[0..2];
		defined ($stack)	? ($stack 	? do {$me->{'stack'} = $stack;
											  $me->{'_seen'} = $seen;}
										: do {my @r = $me->_path (@_);
											  unless (defined @r) {
												  warn $me->{'err'}.=sprintf (" at %s line %s", (caller)[1,2])."\n";
								  				  return;
											  }
											  return wantarray ? @r : $r[1]}
							  )
							: do {warn $me->{'err'}.=sprintf (" at %s line %s", (caller)[1,2])."\n";
								  return};

		$me->{'level'}	= $#{$me->{'stack'}};
		my @res 		= $me->_handle_item ($stack, $seen, $me->{'contexts'}, $context);
		(@{$me}{'path','val','key','level','vref','ppath','parent'}) = @res;

		if ($me->{'err'}) {
			warn $me->{'err'} .= sprintf (" at %s line %s", (caller)[1,2])."\n";
		}
		return wantarray ? (defined ($me->{'key'}) ? (@{$me}{'path','val','key','level','vref','ppath','parent'}) : ())
						 : (defined ($me->{'key'}) || undef);
	}


	sub keys {
		my $me			= shift;
		my $path		= defined ($_[0]) ? shift : '';
		my @_keys;
		$me->{'err'}	= undef;

		my ($elem, $context) = $me->_get_item ($path);
		warn ($me->{'err'}.sprintf(" at %s line %s", (caller)[1,2])."\n") && return
			unless defined $elem;

		my $stack		= [[ $me->_init($elem), '' ]];
		my $seen		= {};
		my $contexts	= {};
		$seen->{${$stack->[0]}[-2]} = $context;

		while ( my $key = ($me->_handle_item ($stack, $seen, $contexts, $context))[0]) {
			warn $me->{'err'}.sprintf(" at %s line %s", (caller)[1,2])."\n" if $me->{'err'};
			push @_keys, $key;
		}

		return wantarray ? @_keys : scalar @_keys
	}

	sub values {
		my $me 			= shift;
		my $path		= defined ($_[0]) ? shift : '';
		my @_vals;
		$me->{'err'}	= undef;

		my ($elem, $context) = $me->_get_item ($path);
		warn ($me->{'err'}.sprintf(" at %s line %s", (caller)[1,2])."\n") && return
			unless defined $elem;

		my $stack 		= [[ $me->_init($elem, length ($path) ? 1 : 0), '' ]];
		my $seen 		= {};
		my $contexts	= {};
		$seen->{${$stack->[0]}[-2]} = $context;

		my ($key, $val) ;
		while ( ($key, $val) = ($me->_handle_item($stack, $seen, $contexts, $context))[0, 1] ) {
			warn $me->{'err'}.sprintf(" at %s line %s", (caller)[1,2])."\n" if $me->{'err'};
			push @_vals, $val;
		}
		return wantarray ? @_vals : scalar @_vals
	}


	sub reset {
		my $me		= shift;
		my $path	= shift;
		chomp ($path) if defined ($path);
		$path		=~ s/[.+?*]$// if defined ($path);

		defined $path 	? ( return exists ($me->{'contexts'}{$path}) && delete ($me->{'contexts'}{$path}) ? 1 : undef)
					  	: ($me->{'contexts'} = {});

		$me->{'stack'}	= $me->{'root_context'}{'item'} = [ [@{$me->{'root'}}] ];

		$me->{'_seen'}	= {};
 		my $vp = ${$me->{'stack'}[0]}[-2];chomp $vp;
		$me->{'_seen'}{$vp}	= $me->{'root_context'}{'seen'}{$vp}	= 'ROOT OBJECT';

		$me->{'err'}	= undef;

	}


	sub _ref_ex{
		my $me = shift;
		my ($r, $c, $t, $rt);
		my $i = defined $_[1] && $_[1] > 0 || 0;
		local $^W = undef;

		unless (ref $_[0]) {
			if ($_[0] =~ /^-FILE:.+/) {
				($rt, $r) = $me->{'_cfg'}{'_known_refs_'}[$i]{'VFILE'} ? ('VFILE', 1) : ('undef', 0);
			}else{
				($rt, $r) = ('undef', 0);
			}
		}else{
			($c, $t)	= $_[0] =~ /(.+)=(.+)\(/;
			($t)		= $_[0] =~ /(.+)\(/ unless $c;
			($rt, $r)   = $me->{'_cfg'}{'_known_refs_'}[$i]{$c}	? ($c, 1)
															: ($me->{'_cfg'}{'_known_refs_'}[$i]{$t}	? ($t, 1)
																										: ('undef', 0)
															   );
		}
		return wantarray ? ($rt, $r) : $rt;
	};


	sub _init {
		my $me = shift;
		return $init{$me->_ref_ex($_[0])}->(@_)
	}


	# erhält:	- String mit Pfad zu Unter-Datenstruktur (a.1.b[*])
	# liefert:	- item_ref (wie ein 'stack'-Element), die auf die
	#			  per $_[0]=Pfad angegebene Unter-Datenstruktur verweist
	#			- $seen-Hash