tieregistry.pm

ARM上的如果你对底层感兴趣

}


sub _Path
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
    @_  and  croak "Usage:  \$arrRef= \$key->_Path;";
    $self= $RegObj   unless  ref($self);
    $self->{PATH};
}


sub Machine
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
    @_  and  croak "Usage:  \$machine= \$key->Machine;";
    $self= $RegObj   unless  ref($self);
    $self->{MACHINE};
}


sub Access
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
    @_  and  croak "Usage:  \$access= \$key->Access;";
    $self= $RegObj   unless  ref($self);
    $self->{ACCESS};
}


sub OS_Delimiter
{
  my $self= shift(@_);
    @_  and  croak "Usage:  \$backslash= \$key->OS_Delimiter;";
    $self->{OS_DELIM};
}


sub _Roots
{
  my $self= shift(@_);
    $self= tied(%$self)  if  ref($self)  &&  tied(%$self);
    @_  and  croak "Usage:  \$varName= \$key->_Roots;";
    $self= $RegObj   unless  ref($self);
    $self->{ROOTS};
}


sub Roots
{
  my $self= shift(@_);
    $self= tied(%$self)  if  ref($self)  &&  tied(%$self);
    @_  and  croak "Usage:  \$hashRef= \$key->Roots;";
    $self= $RegObj   unless  ref($self);
    eval "\\%$self->{ROOTS}";
}


sub TIEHASH
{
  my( $this )= shift(@_);
    $this= tied(%$this)  if  ref($this)  &&  tied(%$this);
  my( $key )= @_;
    if(  1 == @_  &&  ref($key)  &&  "$key" =~ /=/  ) {
	return $key;	# $key is already an object (blessed reference).
    }
    return $this->new( @_ );
}


sub Tie
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
  my( $hRef )= @_;
    if(  1 != @_  ||  ! ref($hRef)  ||  "$hRef" !~ /(^|=)HASH\(/  ) {
	croak "Usage: \$key->Tie(\\\%hash);";
    }
    tie %$hRef, ref($self), $self;
}


sub TiedRef
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
  my $hRef= @_ ? shift(@_) : {};
    return wantarray ? () : undef   if  ! defined($self);
    $self->Tie($hRef);
    bless $hRef, ref($self);
    $hRef;
}


sub _Flags
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
  my $oldFlags= $self->{FLAGS};
    if(  1 == @_  ) {
	$self->{FLAGS}= shift(@_);
    } elsif(  0 != @_  ) {
	croak "Usage:  \$oldBits= \$key->_Flags(\$newBits);";
    }
    $oldFlags;
}


sub ArrayValues
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
  my $oldFlag= $Flag_ArrVal == ( $Flag_ArrVal & $self->{FLAGS} );
    if(  1 == @_  ) {
      my $bool= shift(@_);
	if(  $bool  ) {
	    $self->{FLAGS} |= $Flag_ArrVal;
	} else {
	    $self->{FLAGS} &= ~( $Flag_ArrVal | $Flag_TieVal );
	}
    } elsif(  0 != @_  ) {
	croak "Usage:  \$oldBool= \$key->ArrayValues(\$newBool);";
    }
    $oldFlag;
}


sub TieValues
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
  my $oldFlag= $Flag_TieVal == ( $Flag_TieVal & $self->{FLAGS} );
    if(  1 == @_  ) {
      my $bool= shift(@_);
	if(  $bool  ) {
	    croak "${PACK}->TieValues cannot be enabled with this version";
	    $self->{FLAGS} |= $Flag_TieVal;
	} else {
	    $self->{FLAGS} &= ~$Flag_TieVal;
	}
    } elsif(  0 != @_  ) {
	croak "Usage:  \$oldBool= \$key->TieValues(\$newBool);";
    }
    $oldFlag;
}


sub FastDelete
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
  my $oldFlag= $Flag_FastDel == ( $Flag_FastDel & $self->{FLAGS} );
    if(  1 == @_  ) {
      my $bool= shift(@_);
	if(  $bool  ) {
	    $self->{FLAGS} |= $Flag_FastDel;
	} else {
	    $self->{FLAGS} &= ~$Flag_FastDel;
	}
    } elsif(  0 != @_  ) {
	croak "Usage:  \$oldBool= \$key->FastDelete(\$newBool);";
    }
    $oldFlag;
}


sub SplitMultis
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
  my $oldFlag= $Flag_Split == ( $Flag_Split & $self->{FLAGS} );
    if(  1 == @_  ) {
      my $bool= shift(@_);
	if(  $bool  ) {
	    $self->{FLAGS} |= $Flag_Split;
	} else {
	    $self->{FLAGS} &= ~$Flag_Split;
	}
    } elsif(  0 != @_  ) {
	croak "Usage:  \$oldBool= \$key->SplitMultis(\$newBool);";
    }
    $oldFlag;
}


sub DWordsToHex
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
  my $oldFlag= $Flag_HexDWord == ( $Flag_HexDWord & $self->{FLAGS} );
    if(  1 == @_  ) {
      my $bool= shift(@_);
	if(  $bool  ) {
	    $self->{FLAGS} |= $Flag_HexDWord;
	} else {
	    $self->{FLAGS} &= ~$Flag_HexDWord;
	}
    } elsif(  0 != @_  ) {
	croak "Usage:  \$oldBool= \$key->DWordsToHex(\$newBool);";
    }
    $oldFlag;
}


sub FixSzNulls
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
  my $oldFlag= $Flag_FixNulls == ( $Flag_FixNulls & $self->{FLAGS} );
    if(  1 == @_  ) {
      my $bool= shift(@_);
	if(  $bool  ) {
	    $self->{FLAGS} |= $Flag_FixNulls;
	} else {
	    $self->{FLAGS} &= ~$Flag_FixNulls;
	}
    } elsif(  0 != @_  ) {
	croak "Usage:  \$oldBool= \$key->FixSzNulls(\$newBool);";
    }
    $oldFlag;
}


sub DualTypes
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
  my $oldFlag= $Flag_DualTyp == ( $Flag_DualTyp & $self->{FLAGS} );
    if(  1 == @_  ) {
      my $bool= shift(@_);
	if(  $bool  ) {
	    croak "${PACK}->DualTypes cannot be enabled since ",
		  "SetDualVar module not installed"
	      unless  $_SetDualVar;
	    $self->{FLAGS} |= $Flag_DualTyp;
	} else {
	    $self->{FLAGS} &= ~$Flag_DualTyp;
	}
    } elsif(  0 != @_  ) {
	croak "Usage:  \$oldBool= \$key->DualTypes(\$newBool);";
    }
    $oldFlag;
}


sub DualBinVals
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
  my $oldFlag= $Flag_DualBin == ( $Flag_DualBin & $self->{FLAGS} );
    if(  1 == @_  ) {
      my $bool= shift(@_);
	if(  $bool  ) {
	    croak "${PACK}->DualBinVals cannot be enabled since ",
		  "SetDualVar module not installed"
	      unless  $_SetDualVar;
	    $self->{FLAGS} |= $Flag_DualBin;
	} else {
	    $self->{FLAGS} &= ~$Flag_DualBin;
	}
    } elsif(  0 != @_  ) {
	croak "Usage:  \$oldBool= \$key->DualBinVals(\$newBool);";
    }
    $oldFlag;
}


sub GetOptions
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
  my( $opt, $meth, @old );
    foreach $opt (  @_  ) {
	$meth= $_opt_subs{$opt};
	if(  defined $meth  ) {
	    if(  $opt eq "AllowLoad"  ||  $opt eq "AllowSave"  ) {
		croak "${PACK}->GetOptions:  Getting current setting of $opt ",
		      "not supported in this release";
	    }
	    push(  @old,  $self->$meth()  );
	} else {
	    croak "${PACK}->GetOptions:  Invalid option ($opt) ",
		  "not one of ( ", join(" ",grep !/^Allow/, @_opt_subs), " )";
	}
    }
    return wantarray ? @old : $old[-1];
}


sub SetOptions
{
  my $self= shift(@_);
    # Don't get object if hash ref so "ref" returns original ref.
  my( $opt, $meth, @old );
    while(  @_  ) {
	$opt= shift(@_);
	$meth= $_opt_subs{$opt};
	if(  ! @_  ) {
	    croak "${PACK}->SetOptions:  Option value missing ",
		  "after option name ($opt)";
	} elsif(  defined $meth  ) {
	    push(  @old,  $self->$meth( shift(@_) )  );
	} elsif(  $opt eq substr("reference",0,length($opt))  ) {
	    shift(@_)   if  @_;
	    push(  @old,  $self  );
	} else {
	    croak "${PACK}->SetOptions:  Invalid option ($opt) ",
		  "not one of ( @_opt_subs )";
	}
    }
    return wantarray ? @old : $old[-1];
}


sub _parseTiedEnt
{
  my $self= shift(@_);
    $self= tied(%$self)  if  tied(%$self);
  my $ent= shift(@_);
  my $delim= shift(@_);
  my $dlen= length( $delim );
  my $parent= @_ ? shift(@_) : 0;
  my $off;
    if(  $delim x 2 eq substr($ent,0,2*$dlen)  &&  "NONE" eq $self->Handle  ) {
	if(  0 <= ( $off= index( $ent, $delim x 2, 2*$dlen ) )  ) {
	    (  substr( $ent, 0, $off ),  substr( $ent, 2*$dlen+$off )  );
	} elsif(  $delim eq substr($ent,-$dlen)  ) {
	    ( substr($ent,0,-$dlen) );
	} elsif(  2*$dlen <= ( $off= rindex( $ent, $delim ) )  ) {
	    (  substr( $ent, 0, $off ),  undef,  substr( $ent, $dlen+$off )  );
	} elsif(  $parent  ) {
	    ();
	} else {
	    ( $ent );
	}
    } elsif(  $delim eq substr($ent,0,$dlen)  &&  "NONE" ne $self->Handle  ) {
	( undef, substr($ent,$dlen) );
    } elsif(  $self->{MEMBERS}  &&  $self->_MembersHash->{$ent}  ) {
	( substr($ent,0,-$dlen) );
    } elsif(  0 <= ( $off= index( $ent, $delim x 2 ) )  ) {
	(  substr( $ent, 0, $off ),  substr( $ent, 2*$dlen+$off ) );
    } elsif(  $delim eq substr($ent,-$dlen)  ) {
	if(  $parent
	 &&  0 <= ( $off= rindex( $ent, $delim, length($ent)-2*$dlen ) )  ) {
	    (  substr($ent,0,$off),  undef,  undef,
	       substr($ent,$dlen+$off,-$dlen)  );
	} else {
	    ( substr($ent,0,-$dlen) );
	}
    } elsif(  0 <= ( $off= rindex( $ent, $delim ) )  ) {
	(  substr( $ent, 0, $off ),  undef,  substr( $ent, $dlen+$off )  );
    } else {
	( undef, undef, $ent );
    }
}


sub FETCH
{
  my $self= shift(@_);
  my $ent= shift(@_);
  my $delim= $self->Delimiter;
  my( $key, $val, $ambig )= $self->_parseTiedEnt( $ent, $delim, 0 );
  my $sub;
    if(  defined($key)  ) {
	if(  defined($self->{MEMBHASH})
	 &&  $self->{MEMBHASH}->{$key.$delim}
	 &&  0 <= index($key,$delim)  ) {
	    return wantarray ? () : undef
	      unless  $sub= $self->new( $key,
			      {"Delimiter"=>$self->OS_Delimiter} );
	    $sub->Delimiter($delim);
	} else {
	    return wantarray ? () : undef
	      unless  $sub= $self->new( $key );
	}
    } else {
	$sub= $self;
    }
    if(  defined($val)  ) {
	return $self->ArrayValues ? [ $sub->GetValue( $val ) ]
				  : $sub->GetValue( $val );
    } elsif(  ! defined($ambig)  ) {
	return $sub->TiedRef;
    } elsif(  defined($key)  ) {
	return $sub->FETCH(  $ambig  );
    } elsif(  "" eq $ambig  ) {
	return $self->ArrayValues ? [ $sub->GetValue( $ambig ) ]
				  : $sub->GetValue( $ambig );
    } else {
      my $data= [ $sub->GetValue( $ambig ) ];
	return $sub->ArrayValues ? $data : $$data[0]
	  if  0 != @$data;
	$data= $sub->new( $ambig );
	return defined($data) ? $data->TiedRef : wantarray ? () : undef;
    }
}


sub _FetchOld
{
  my( $self, $key )= @_;
  my $old= $self->FETCH($key);
    if(  $old  ) {
      my $copy= {};
	%$copy= %$old;
	return $copy;
    }
    # return $^E;
    return _Err;
}