libopensrs-perl 3.0.0-1 / usr / share / perl5 / RACE.pm

package RACE;

use strict;
use NAMEPREP;
use Unicode::String qw(utf8 ucs4 utf16);
Unicode::String->stringify_as('utf8');

my $RACEPrefix = "bq--";

my $STD13Chars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYX0123456789-";
my $Base32Chars = 'abcdefghijklmnopqrstuvwxyz234567';

my $USE_RACE = 1;

sub Initialise
{
	my %args = @_;
	NAMEPREP::Initialise(%args)
}

sub UseRace
{
	my $arg = shift;
	$USE_RACE = $arg;
}

sub DoRACE
{
	my %args = @_;
        my $fulldomainstring =  $args{Domain};	
	#charset is a legacy argument. Not used any more
	my $charset = $args{EncodingType};
	my (@dmnparts,$icntr,$TheUCS4,$extension,$TheIn,$nameprephash);
	my (%result,$racehash);

	if ( (! defined $charset) or ($charset eq "") or (!$USE_RACE))
        {
                $result{OriginalDomain} = $fulldomainstring;
                $result{ConvertedDomain} = $fulldomainstring;
                $result{DomainConverted} = 0;
                return \%result;
        }

	#assume input is in utf8	
	@dmnparts = split(/\./,$fulldomainstring);
	$extension =  lc $dmnparts[$#dmnparts];

	$result{OriginalDomain} = $fulldomainstring;
	$result{DomainConverted} = 0;
	$result{ConvertedDomain} = "";
	for ($icntr=0;$icntr<$#dmnparts;$icntr++)
	{
		my $u = $dmnparts[$icntr];
		$nameprephash = NAMEPREP::nameprep(name => $u);
		if (defined $nameprephash->{error})
		{
        		$result{Error} = "Nameprep Error: " . $nameprephash->{error} . " in: " . $u ;
       			return \%result;
		}
		$result{MapOutput} .= $nameprephash->{mapoutput} . ".";
		$result{NamepreppedDomain} .= $nameprephash->{output} . ".";
		$result{UniHexCodes} .= $nameprephash->{hexin}. "." ;
		$result{NameprepHexCodes} .= $nameprephash->{hexoutput} . ".";
		$TheIn = $nameprephash->{output};

		$TheUCS4 = utf8($TheIn)->ucs4;
		$racehash = UCS4toRACE($TheUCS4);
		if(defined $racehash->{error})
		{
			$result{Error} = "RACE Error: " . $racehash->{error};
			return \%result;
		}
		if($racehash->{DomainConverted})
		{
			$result{DomainConverted} = 1;
			$result{ConvertedDomain} .= $racehash->{result};
		}
		else
		{
			$result{DomainConverted} = 0;
			$result{ConvertedDomain} .= lc $u;		
		} 
		$result{ConvertedDomain} .= ".";
		undef $racehash;	
		undef $nameprephash;
	}
	$result{ConvertedDomain} .= $extension;
	$result{NamepreppedDomain} .= $extension;
	$result{UniHexCodes} .= $extension;
	$result{NameprepHexCodes} .=  $extension;
	$result{MapOutput} .=  $extension;

	if($result{DomainConverted}!=1)
	{
		$result{ConvertedDomain} =  lc $fulldomainstring;
	}

	return \%result;
}

sub UndoRACE
{
	my %args = @_;
	my $fullraceddomainstring = $args{Domain};
	my $charset = $args{EncodingType};
	my (@dmnparts,$extension,%result,$icntr,$TheUCS4,$racehash);

	if ( (! defined $charset) or ($charset eq "") or (!$USE_RACE))
        {
                $result{OriginalDomain} = $fullraceddomainstring;
                return \%result;
        }

	@dmnparts = split(/\./,$fullraceddomainstring);
        $extension =  lc $dmnparts[$#dmnparts];

	for ($icntr=0;$icntr<$#dmnparts;$icntr++)
        {
		my $u = $dmnparts[$icntr];
		$racehash = RACEtoUCS4($u);
		if(not $racehash->{is_wrong_prefix})
		{	
			if(defined $racehash->{error})
			{
				$result{Error} = $racehash->{error};
				return \%result;
			}	
			$result{OriginalDomain} .= ucs4($racehash->{OriginalDomain})->utf8;
			$result{DomainConverted} = 1;
		}
		else
		{
			$result{OriginalDomain} .= $u;
		}
		$result{OriginalDomain} .= ".";
	}
	$result{OriginalDomain} .= $extension;

	return \%result;
}

sub RACEtoUCS4 {
        my $InString = lc(shift(@_));
        my ($PostBase32, @DeArr, $i, $U1, $N1, $OutString, $LCheck,
                $InputPointer, @UpperUniq, %UpperSeen,%result,@CheckArr);
        # Strip any whitespace
        $InString =~ s/\s*//g;
        # Strip of the prefix string
        unless(substr($InString, 0, length($RACEPrefix)) eq $RACEPrefix)
                {	
			$result{error} = "The input to RACEtoUCS4 did not start with '$RACEPrefix'";
			#we do not want to introduce an error if the prefix is bad.
			$result{is_wrong_prefix} = 1;
			return \%result;
		}
        $InString = substr($InString, length($RACEPrefix));

	my $pb32hash =  Base32Decode($InString); 
	if(defined $pb32hash->{error})
	{
		$result{error} = $pb32hash->{error};
		return \%result;
	}
        $PostBase32 = $pb32hash->{result};
        @DeArr = split(//, $PostBase32);
 
        # Reverse the compression
        $U1 = $DeArr[0];  # Step 1a
        if($#DeArr < 1)  # Step 1b
                {
			$result{error} = "The output of Base32Decode was zero length.";
			return \%result;
		}
 
        unless ($U1 eq "\xd8") {  # Step 1c
                $i = 1;
                until($i > $#DeArr) {  # Step 2a
                        $N1 = $DeArr[$i++];  # Step 2b
                        unless($N1 eq "\xff")  {  # Step 2c
                                if(($U1 eq "\x00") and ($N1 eq "\x99"))  # Step 3
                                        { 
						$result{error} = "Found 0099 in the input to RACEtoUCS4, step 3.";
						return \%result;
					}
                                $OutString .= $U1 . $N1;  # Step 4
                        } else {
                                if($i > $#DeArr)  # Step 5
                                        { 
						$result{error} = "Input in RACE string at octet $i too short at step 5";
						return \%result;
					}
                                $N1 = $DeArr[$i++];  # Step 6a
                                if($N1 eq "\x99")  # Step 6b
                                        { $OutString .= $U1 . "\xff" }
                                else  # Step 7
                                        { $OutString .= "\x00" . $N1 }
                        }
                }
                if((length($OutString) % 2) == 1)  # Step 11
                        { 
				$result{error} = "The output of RACEtoUCS4 for compressed input was an odd number of characters at step 11.";
				return \%result;
			}
        } else {  # Was not compressed
                $LCheck = substr(join('', @DeArr), 1);  # Step 8a
                if((length($LCheck) % 2 ) == 1 )  # Step 8b
                        { 
				$result{error} = "The output of RACEtoUCS4 for uncompressed input was an odd number of characters at step 8b";
				return \%result;
			}
                # Do the step 9 check to be sure the right length was used
		 @CheckArr = split(//, $LCheck);
                for($InputPointer = 0; $InputPointer <= $#CheckArr; $InputPointer += 2) {
                        unless ($UpperSeen{$CheckArr[$InputPointer]}) {
                                $UpperSeen{$CheckArr[$InputPointer]} = 1;
                                push (@UpperUniq, $CheckArr[$InputPointer])
                        }
                }
                # Should it have been compressed?
                if( ($#UpperUniq == 0) or
                        ( ($#UpperUniq == 1) and
                                (($UpperUniq[0] eq "\x00") or ($UpperUniq[1] eq "\x00"))
                        )
                ) { 
			$result{error} = "Input to RACEtoUCS4 failed during LCHECK format test in step 9.";
			return \%result; 
			}
                if((length($LCheck) % 2) == 1)  # Step 10a
                        { 
				$result{error} = "The output of RACEtoUCS4 for uncompressed input was an odd number of characters at step 10a";
				return \%result;
			}
                $OutString = $LCheck
        }
        if(CheckForSTD13Name($OutString))
                { 
			$result{error} = "Found all-STD13 name before output of RACEtoUCS4";
			return \%result;
		}
        if(CheckForBadSurrogates($OutString))
                { 
			$result{error} = "Found bad surrogate before output of RACEtoUCS4";
			return \%result;
		}
	$result{OriginalDomain} = utf16($OutString)->ucs4;
        return \%result;
}

sub UCS4toRACE {
        my $InString = shift(@_);
        my (@InArr, $InStr, $InputPointer, $DoStep3, @UpperUniq, %UpperSeen);
        my ($U1, $U2, $N1, $CompString,$PostBase32, %result, $DieOrd);
 
        # Make an array of the UTF16 octets
        @InArr = split(//, ucs4($InString)->utf16);
        $InStr = join('', @InArr);
        if(CheckForSTD13Name($InStr))
	{
		#the name contains only ascii chars
		$result{result} = $InStr;
		$result{DomainConverted} = 0;
		return \%result;	
	}
        # Prepare for steps 1 and 2 by making an array of the upper octets
        for($InputPointer = 0; $InputPointer <= $#InArr; $InputPointer += 2) {
                unless ($UpperSeen{$InArr[$InputPointer]}) {
                        $UpperSeen{$InArr[$InputPointer]} = 1;
                        push (@UpperUniq, $InArr[$InputPointer])
                }
        }
        if($#UpperUniq == 0) { # Step 1
                $U1 = $UpperUniq[0];
                $DoStep3 = 0;
        } elsif($#UpperUniq == 1) {  # Step 2
                if($UpperUniq[0] eq "\x00") {
                        $U1 = $UpperUniq[1];
                        $DoStep3 = 0;
                } elsif($UpperUniq[1] eq "\x00") {
                        $U1 = $UpperUniq[0];
                        $DoStep3 = 0;
                } else { $DoStep3 = 1 }
        } else { $DoStep3 = 1 }
        # Now output based on the value of $DoStep3
        if($DoStep3) {  # Step 3
                $CompString = "\xd8" . join('', @InArr);
        } else {
                if(($U1 ge "\xd8") and ($U1 le "\xdf")) {  # Step 4a
                        $DieOrd = sprintf("%04lX", ord($U1));
                        $result{error} = "Found invalid input to UCS4toRACE step 4a: $DieOrd.";
			return \%result;
                }
                $CompString = $U1;  # Step 4b
                $InputPointer = 0;
                while($InputPointer <= $#InArr) {  # Step 5a
                        $U2 = $InArr[$InputPointer++]; $N1 = $InArr[$InputPointer++];  # Step 5b
                        if(($U2 eq "\x00") and ($N1 eq "\x99"))  # Step 5c
                                {	$result{error} = "Found U+0099 in input stream to UCS4toRACE step 5c.";
					return \%result;
				}
                        if( ($U2 eq $U1) and ($N1 ne "\xff") )  # Step 6
			            { $CompString .= $N1 }
                        elsif( ($U2 eq $U1) and ($N1 eq "\xff") )  # Step 7
                                { $CompString .= "\xff\x99" }
                        else { $CompString .= "\xff" . $N1 }  # Step 8
                }
        }
        if(length($CompString) >= 37)
        {  
		$result{error} = "Lenth of compressed string was >= 37 in UCS4toRACE.";
		return \%result;
	}
        $PostBase32 = Base32Encode($CompString);
	$result{DomainConverted} = 1; 
	$result{result} = "$RACEPrefix$PostBase32";
        return \%result;
}

sub CheckForSTD13Name 
{
        # The input is in UTF-16
        my $InCheck = shift(@_);
        my (@CheckArr, $CheckPtr, $Lower, $Upper,);
        @CheckArr = split(//, $InCheck);
        $CheckPtr = 0;
        until($CheckPtr > $#CheckArr) {
                $Upper = $CheckArr[$CheckPtr++];
                $Lower = $CheckArr[$CheckPtr++];
                if(($Upper ne "\x00") or
                        (index($STD13Chars, $Lower) == -1) ) { return 0 }
        }
        return 1;
}

sub Base32Encode {
        my($ToEncode) = shift(@_);
        my ($i, $OutString, $CompBits, $FivePos, $FiveBitsString, $FiveIndex);
 
        # Turn the compressed string into a string that represents the bits as
        #    0 and 1. This is wasteful of space but easy to read and debug.
        $CompBits = '';
        foreach $i (split(//, $ToEncode)) { $CompBits .= unpack("B8", $i) };
 
        # Pad the value with enough 0's to make it a multiple of 5
        if((length($CompBits) % 5) != 0)
                { $CompBits .= '0' x (5 - (length($CompBits) % 5)) };  # Step 1a
        $FivePos = 0;  # Step 1b
        do {
                $FiveBitsString = substr($CompBits, $FivePos, 5);  # Step 2
                $FiveIndex = unpack("N", pack("B32", ('0' x 27) . $FiveBitsString));
                $OutString .= substr($Base32Chars, $FiveIndex, 1);  # Step 3
                $FivePos += 5;  # Step 4a
        } until($FivePos == length($CompBits));  # Step 4b
        return $OutString;
}

sub Base32Decode {
        my ($ToDecode) = shift(@_);
        my ($InputCheck, $OutString, $DeCompBits, $DeCompIndex, @DeArr, $i,
                $PaddingLen, $PaddingContent,%result,$InChar, $Padding);
 
        $InputCheck = length($ToDecode) % 8;  # Step 1
        if(($InputCheck == 1) or
           ($InputCheck == 3) or
           ($InputCheck == 6))
                { 
			$result{error} = "Input to Base32Decode was a bad mod length: $InputCheck\n";
			return \%result;
		}
 
        # $DeCompBits is a string that represents the bits as
        #    0 and 1. This is wasteful of space but easy to read and debug.
        $DeCompBits = '';
        foreach $InChar (split(//, $ToDecode)) {
                if(index($Base32Chars, $InChar) == -1)  # Character not in base set
                        { 
				$result{error} = "Input to Base32Decode had a bad character: $InChar\n";
				return \%result;
			}
                $DeCompIndex = pack("N", index($Base32Chars, $InChar));
                $DeCompBits .= substr(unpack("B32", $DeCompIndex), 27);
        }
 
        # Step 5
        $Padding = length($DeCompBits) % 8;
        $PaddingContent = substr($DeCompBits, (length($DeCompBits) - $Padding));
        unless(index($PaddingContent, '1') == -1)
                { 
			$result{error} = "Found non-zero padding in Base32Decode\n";
			return \%result;
		}
 
        # Break the decompressed string into octets for returning
        @DeArr = ();
        for($i = 0; $i < int(length($DeCompBits) / 8); $i++) {
                $DeArr[$i] =
                        chr(unpack("N", pack("B32", ('0' x 24) . substr($DeCompBits, $i * 8, 8))));
        }
        $result{result} = join('', @DeArr);
        return \%result;
}

sub CheckForBadSurrogates {
        # The input is in UTF-16
        my $InCheck = shift(@_);
        my (@CheckArr, $CheckPtr, $Upper1, $Upper2,$HighSurr,$LowSurr);
        @CheckArr = split(//, $InCheck);
        $CheckPtr = 0;
        $HighSurr = "\xD8\xD9\xDA\xDB";
        $LowSurr = "\xDC\xDD\xDE\xDF";
        until($CheckPtr > $#CheckArr) {
                # Check for bad half-pair
                if((($CheckPtr + 2 ) >= $#CheckArr) and
                        (index($HighSurr.$LowSurr, $CheckArr[$CheckPtr]) > -1 )) {
                                return 1;
                }
                last unless(defined($CheckArr[$CheckPtr + 4]));
                $Upper1 = $CheckArr[$CheckPtr += 2];
                $Upper2 = $CheckArr[$CheckPtr += 2];
                if( ((index($HighSurr, $Upper1) > -1) and
                         (index($LowSurr, $Upper2) == -1))
                        or
                        ((index($HighSurr, $Upper1) == -1) and
                         (index($LowSurr, $Upper2) > -1))) {
                        return 1;
                }
        }
        return 0;
}

return 1;