intltool-merge

这是一个用于管理个人事物安排的应用程序

	    if (/^"((\\.|[^\\])*)"/) 
            {
	        $msgid .= unescape_po_string($1) if $inmsgid;
	        $msgstr .= unescape_po_string($1) if $inmsgstr;
	    }
	}
	$translations{$lang, $msgid} = $msgstr if $inmsgstr && $msgid && $msgstr;
    }
}

sub finalize
{
}

sub unescape_one_sequence
{
    my ($sequence) = @_;

    return "\\" if $sequence eq "\\\\";
    return "\"" if $sequence eq "\\\"";
    return "\n" if $sequence eq "\\n";
    return "\r" if $sequence eq "\\r";
    return "\t" if $sequence eq "\\t";
    return "\b" if $sequence eq "\\b";
    return "\f" if $sequence eq "\\f";
    return "\a" if $sequence eq "\\a";
    return chr(11) if $sequence eq "\\v"; # vertical tab, see ascii(7)

    return chr(hex($1)) if ($sequence =~ /\\x([0-9a-fA-F]{2})/);
    return chr(oct($1)) if ($sequence =~ /\\([0-7]{3})/);

    # FIXME: Is \0 supported as well? Kenneth and Rodney don't want it, see bug #48489

    return $sequence;
}

sub unescape_po_string
{
    my ($string) = @_;

    $string =~ s/(\\x[0-9a-fA-F]{2}|\\[0-7]{3}|\\.)/unescape_one_sequence($1)/eg;

    return $string;
}

## NOTE: deal with < - &lt; but not > - &gt;  because it seems its ok to have 
## > in the entity. For further info please look at #84738.
sub entity_decode
{
    local ($_) = @_;

    s/&apos;/'/g; # '
    s/&quot;/"/g; # "
    s/&amp;/&/g;
    s/&lt;/</g;

    return $_;
}
 
# entity_encode: (string)
#
# Encode the given string to XML format (encode '<' etc).

sub entity_encode
{
    my ($pre_encoded) = @_;

    my @list_of_chars = unpack ('C*', $pre_encoded);

    # with UTF-8 we only encode minimalistic
    return join ('', map (&entity_encode_int_minimalist, @list_of_chars));
}

sub entity_encode_int_minimalist
{
    return "&quot;" if $_ == 34;
    return "&amp;" if $_ == 38;
    return "&apos;" if $_ == 39;
    return "&lt;" if $_ == 60;
    return chr $_;
}

sub entity_encoded_translation
{
    my ($lang, $string) = @_;

    my $translation = $translations{$lang, $string};
    return $string if !$translation;
    return entity_encode ($translation);
}

## XML (bonobo-activation specific) merge code

sub ba_merge_translations
{
    my $source;

    {
       local $/; # slurp mode
       open INPUT, "<$FILE" or die "can't open $FILE: $!";
       $source = <INPUT>;
       close INPUT;
    }

    open OUTPUT, ">$OUTFILE" or die "can't open $OUTFILE: $!";

    while ($source =~ s|^(.*?)([ \t]*<\s*$w+\s+($w+\s*=\s*"$q"\s*)+/?>)([ \t]*\n)?||s) 
    {
        print OUTPUT $1;

        my $node = $2 . "\n";

        my @strings = ();
        $_ = $node;
	while (s/(\s)_($w+\s*=\s*"($q)")/$1$2/s) {
             push @strings, entity_decode($3);
        }
	print OUTPUT;

	my %langs;
	for my $string (@strings) 
        {
	    for my $lang (keys %po_files_by_lang) 
            {
                $langs{$lang} = 1 if $translations{$lang, $string};
	    }
	}
	
	for my $lang (sort keys %langs) 
        {
	    $_ = $node;
	    s/(\sname\s*=\s*)"($q)"/$1"$2-$lang"/s;
	    s/(\s)_($w+\s*=\s*")($q)"/$1 . $2 . entity_encoded_translation($lang, $3) . '"'/seg;
	    print OUTPUT;
        }
    }

    print OUTPUT $source;

    close OUTPUT;
}


## XML (non-bonobo-activation) merge code


# Process tag attributes
#   Only parameter is a HASH containing attributes -> values mapping
sub getAttributeString
{
    my $sub = shift;
    my $do_translate = shift || 0;
    my $language = shift || "";
    my $result = "";
    my $translate = shift;
    foreach my $e (reverse(sort(keys %{ $sub }))) {
	my $key    = $e;
	my $string = $sub->{$e};
	my $quote = '"';
	
	$string =~ s/^[\s]+//;
	$string =~ s/[\s]+$//;
	
	if ($string =~ /^'.*'$/)
	{
	    $quote = "'";
	}
	$string =~ s/^['"]//g;
	$string =~ s/['"]$//g;

	if ($do_translate && $key =~ /^_/) {
	    $key =~ s|^_||g;
	    if ($language) {
		
		# Handle translation
		#
		my $decode_string = entity_decode($string);
		my $translation = $translations{$language, $decode_string};
		if ($translation) {
		    $translation = entity_encode($translation);
		    $string = $translation;
                    $$translate = 2;
		} else {
                    $$translate = 2; # we still want translations for deep nesting (FIXME: this will cause
                                     # problems since we might get untranslated duplicated entries, but with xml:lang set)
                    # Fix would be to set it here to eg. 3, and do a check in traverse() to see if any of the containing tags
                    # really need translation, and only emit "translation" if there is (this means parsing same data twice)
                }
            } else {
                 $$translate = 2 if ($translate && (!$$translate)); # watch not to "overwrite" if $translate == 2
            }
	}
	
	$result .= " $key=$quote$string$quote";
    }
    return $result;
}

# Returns a translatable string from XML node, it works on contents of every node in XML::Parser tree
#   doesn't support nesting of translatable tags (i.e. <_blah>this <_doh>doesn't</_doh> work</_blah> -- besides
#   can you define the correct semantics for this?)
#

sub getXMLstring
{
    my $ref = shift;
    my @list = @{ $ref };
    my $result = "";

    my $count = scalar(@list);
    my $attrs = $list[0];
    my $index = 1;

    while ($index < $count) {
	my $type = $list[$index];
	my $content = $list[$index+1];
        if (! $type ) {
	    # We've got CDATA
	    if ($content) {
		# lets strip the whitespace here, and *ONLY* here
                $content =~ s/\s+/ /gs if (!((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/)));
		$result .= ($content);
	    } else {
		#print "no cdata content when expected it\n"; # is this possible, is this ok?
		# what to do if this happens?
		# Did I mention that I hate XML::Parser tree style?
	    }
	} else {
	    # We've got another element
	    $result .= "<$type";
	    $result .= getAttributeString(@{$content}[0], 0); # no nested translatable elements
	    if ($content) {
		my $subresult = getXMLstring($content);
		if ($subresult) {
		    $result .= ">".$subresult . "</$type>";
		} else {
		    $result .= "/>";
		}
	    } else {
		$result .= "/>";
	    }
	}
	$index += 2;
    }
    return $result;
}

# Translate list of nodes if necessary
sub translate_subnodes
{
    my $fh = shift;
    my $content = shift;
    my $language = shift || "";
    my $singlelang = shift || 0;

    my @nodes = @{ $content };

    my $count = scalar(@nodes);
    my $index = 0;
    while ($index < $count) {
        my $type = $nodes[$index];
        my $rest = $nodes[$index+1];
        if ($singlelang) {
            my $oldMO = $MULTIPLE_OUTPUT;
            $MULTIPLE_OUTPUT = 1;
            traverse($fh, $type, $rest, $language);
            $MULTIPLE_OUTPUT = $oldMO;
        } else {
            traverse($fh, $type, $rest, $language);
        }
        $index += 2;
    }
}

sub traverse
{
    my $fh = shift; 
    my $nodename = shift;
    my $content = shift;
    my $language = shift || "";

    if (!$nodename) {
	if ($content =~ /^[\s]*$/) {
	    $leading_space .= $content;
	}
	print $fh $content;
    } else {
	# element
	my @all = @{ $content };
	my $attrs = shift @all;
	my $translate = 0;
	my $outattr = getAttributeString($attrs, 1, $language, \$translate);

	if ($nodename =~ /^_/) {
	    $translate = 1;
	    $nodename =~ s/^_//;
	}
	my $lookup = '';
	print $fh "<$nodename", $outattr;
	if ($translate) {
	    $lookup = getXMLstring($content);
            if (!((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/))) {
                $lookup =~ s/^\s+//s;
                $lookup =~ s/\s+$//s;
            }

	    if ($lookup || $translate == 2) {
                my $translation = $translations{$language, $lookup};
                if ($MULTIPLE_OUTPUT && ($translation || $translate == 2)) {
                    $translation = $lookup if (!$translation);
                    print $fh " xml:lang=\"", $language, "\"" if $language;
                    print $fh ">";
                    if ($translate == 2) {
                        translate_subnodes($fh, \@all, $language, 1);
                    } else {
                        print $fh $translation;
                    }
                    print $fh "</$nodename>";

                    return; # this means there will be no same translation with xml:lang="$language"...
                            # if we want them both, just remove this "return"
                } else {
                    print $fh ">";
                    if ($translate == 2) {
                        translate_subnodes($fh, \@all, $language, 1);
                    } else {
                        print $fh $lookup;
                    }
                    print $fh "</$nodename>";
                }
	    } else {
		print $fh "/>";
	    }

	    for my $lang (sort keys %po_files_by_lang) {
                    if ($MULTIPLE_OUTPUT && $lang ne "$language") {
                        next;
                    }
		    if ($lang) {
                        # Handle translation
                        #
                        my $translate = 0;
                        my $localattrs = getAttributeString($attrs, 1, $lang, \$translate);
                        my $translation = $translations{$lang, $lookup};
                        if ($translate && !$translation) {
                            $translation = $lookup;
                        }

                        if ($translation || $translate) {
			    print $fh "\n";
			    $leading_space =~ s/.*\n//g;
			    print $fh $leading_space;
 			    print $fh "<", $nodename, " xml:lang=\"", $lang, "\"", $localattrs, ">";
                            if ($translate == 2) {
                               translate_subnodes($fh, \@all, $lang, 1);
                            } else {
                                print $fh $translation;
                            }
                            print $fh "</$nodename>";
			}
                    }
	    }

	} else {
	    my $count = scalar(@all);
	    if ($count > 0) {
		print $fh ">";
                my $index = 0;
                while ($index < $count) {
                    my $type = $all[$index];
                    my $rest = $all[$index+1];
                    traverse($fh, $type, $rest, $language);
                    $index += 2;
                }
		print $fh "</$nodename>";
	    } else {
		print $fh "/>";
	    }
	}
    }
}

sub intltool_tree_cdatastart
{
    my $expat    = shift;
    my $clist = $expat->{Curlist};
    my $pos   = $#$clist;

    push @$clist, 0 => $expat->original_string();
}

sub intltool_tree_cdataend
{
    my $expat    = shift;
    my $clist = $expat->{Curlist};
    my $pos   = $#$clist;

    $clist->[$pos] .= $expat->original_string();
}

sub intltool_tree_char
{
    my $expat = shift;
    my $text  = shift;
    my $clist = $expat->{Curlist};
    my $pos   = $#$clist;

    # Use original_string so that we retain escaped entities
    # in CDATA sections.
    #
    if ($pos > 0 and $clist->[$pos - 1] eq '0') {
        $clist->[$pos] .= $expat->original_string();
    } else {
        push @$clist, 0 => $expat->original_string();
    }
}

sub intltool_tree_start
{
    my $expat    = shift;
    my $tag      = shift;
    my @origlist = ();

    # Use original_string so that we retain escaped entities
    # in attribute values.  We must convert the string to an
    # @origlist array to conform to the structure of the Tree
    # Style.
    #
    my @original_array = split /\x/, $expat->original_string();
    my $source         = $expat->original_string();

    # Remove leading tag.
    #
    $source =~ s|^\s*<\s*(\S+)||s;

    # Grab attribute key/value pairs and push onto @origlist array.
    #
    while ($source)
    {