sub ParseXmlString
{
    my( $str )= @_;

    my $name=   '(?:\w+:)?\w+';
    my $value=  q< (?: '[^']+' | "[^"]+" ) >;
    my $s=      '\s';
    my $attrib= "$name $s* = $s* $value";
    my $decl=   "< $s* [?] $s* $name (?: $s+ $attrib )* $s* [?] $s* >";
    my $tag=    "< $s* (/?) $s* ($name) (?: $s+ $attrib )* $s* (/?) $s* >";
    my $data=   '(?: [^<>&]+ | &\#?\w+; )+';

    my $hv= {};
    my @stack;
    while(
        $str =~ m{ \G(?:
            ( $decl )   # $1 <?xml ...?>
          | ( $data )   # $2 encoded text
          | ( $tag )    # $3 <...>, $4 '/' or '', $5 tag name, $6 '/' or ''
          | ( . )       # $7 we failed
        ) }xgc
    ) {
        if(  $1  ) {
            $hv->{'.header'}= $1;
        } elsif(  defined $2  ) {
            my $text= $2;
            if(  $text =~ /\S/  ) {
                s-&lt;-<-g,  s-&quot;-"-g,
                s-&gt;->-g,  s-&apos;-'-g,  s-&amp;-&-g
                    for  $text;
                push @{ $hv->{'.data'} }, $text;
            }
        } elsif(  $4  ) {
            $hv= pop @stack;
        } elsif(  $6  ) {
            # We currently just ignore empty tags
        } elsif(  $3  ) {
            my $new= {};
            push @{ $hv->{$5} }, $new;
            push @stack, $hv;
            $hv= $new;
        } elsif(  defined $7  ) {
            my $beg= pos($str);
            my $len= 20;
            $beg -= $len/2;
            if(  $beg < 0  ) {
                $len += $beg;
                $beg= 0;
            }
            die "XML failed to parse byte ", pos($str), " ($7), near '",
                substr( $str, $beg, $len ), "'.\n";
        } else {
            die "Impossible!";
        }
    }
    if(  @stack  ) {
        die "Unclosed XML tags";
    }
    return $hv;
}