- genhdlist2:

  o generate {info,changelog,files}.xml.lzma when they already exist, 
    or when --xml-media-info is used

2 files changed, 99 insertions, 7 deletions

diff --git a/NEWS b/NEWS
index d43c34b..94e4b1d 100644
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,6 @@
 - genhdlist2:
+  o generate {info,changelog,files}.xml.lzma when they already exist, 
+    or when --xml-media-info is used
   o error message when parse_hdlist (partially) fail
   o handle old-rpms.lst (to be generated by youri)
     which will allow keeping rpms for some time without having in hdlist
diff --git a/genhdlist2 b/genhdlist2
index cce5be6..f4452a3 100644
--- a/genhdlist2
+++ b/genhdlist2
@@ -5,6 +5,7 @@
 use URPM;
 use MDV::Packdrakeng;
 use Getopt::Long;
+use Encode;
 
 main();
 
@@ -14,7 +15,7 @@ sub usage () {
 }
 
 sub main() {
-    my %options;
+    my %options = (xml_media_info => 'auto');
 
     GetOptions(
 	'clean' => \$options{no_incremental},
@@ -25,6 +26,7 @@ sub main() {
 	'nolock' => \$options{nolock},
 	'allow-empty-media' => \$options{allow_empty_media},
 	'file-deps=s' => \$options{file_deps},
+	'xml-media-info!' => \$options{xml_media_info},
 	'media_info-dir=s' => \$options{media_info_dir},
 	'h|help' => sub { usage(); exit 0 },
 	'q|quiet' => sub { $options{verbose} = -1 },
@@ -88,11 +90,16 @@ sub do_it {
 
     read_file_deps($urpm, $options{file_deps}) if $options{file_deps};
 
-    build_hdlist($urpm, \%rpms_todo, $media_info_dir, $rpms_dir, $options{no_incremental});
+    if ($options{xml_media_info} eq 'auto') {
+	$options{xml_media_info} = -e "$media_info_dir/info.xml.lzma";
+    }
+    my @xml_media_info = $options{xml_media_info} ? ('info', 'files', 'changelog') : ();
+
+    build_hdlist($urpm, \%rpms_todo, $media_info_dir, $rpms_dir, \@xml_media_info, $options{no_incremental});
     build_synthesis($urpm, "$synthesis.tmp");
 
     if (1) {
-	foreach my $name ('hdlist.cz') {
+	foreach my $name ('hdlist.cz', map { "$_.xml.lzma" } @xml_media_info) {
 	    print "replacing $media_info_dir/$name with $name.tmp\n" if $verbose >= 0;
 	    rename "$media_info_dir/$name.tmp", "$media_info_dir/$name" or die "rename $media_info_dir/$name failed: $?\n";
 	}
@@ -130,7 +137,7 @@ sub read_file_deps {
 }
 
 sub build_hdlist {
-    my ($urpm, $rpms_todo, $media_info_dir, $rpms_dir, $b_no_incremental) = @_;
+    my ($urpm, $rpms_todo, $media_info_dir, $rpms_dir, $xml_media_info, $b_no_incremental) = @_;
 
     my $hdlist = "$media_info_dir/hdlist.cz";
 
@@ -143,6 +150,7 @@ sub build_hdlist {
 
     my $out = {
 	hdlist => $out_hdlist,
+	map { $_ => open_xml_lzma("$media_info_dir/$_.xml.lzma.tmp") } @$xml_media_info
     };
 
     if (-e $hdlist && !$b_no_incremental) {
@@ -151,6 +159,8 @@ sub build_hdlist {
     }
 
     add_new_rpms_to_hdlist($urpm, $rpms_todo, $out, $rpms_dir);
+
+    close_xml($out->{$_}) foreach @$xml_media_info;
 }
 
 sub filter_existing_hdlist {
@@ -207,20 +217,100 @@ sub add_new_rpms_to_hdlist {
     }
 }
 
+sub open_xml_lzma {
+    my ($file) = @_;
+    open(my $F, "| lzma -5 > $file") or die "can't open $file\n";
+    binmode $F, ':utf8';
+    print $F "<media_info>";
+    $F;
+}
+
+sub close_xml {
+    my ($F) = @_;
+    print $F "</media_info>\n";
+}
+
+sub ensure_utf8 {
+    my ($s) = @_;
+    
+    Encode::_utf8_on($s); #- this is done on the copy
+    if (!Encode::is_utf8($s, 1)) {
+	Encode::_utf8_off($_[0]);
+	Encode::from_to($_[0], 'iso-8859-15', 'utf8');
+    }
+}
+
+sub encode_xml {
+    my ($s) = @_;
+    $s =~ s/&/&amp;/g;
+    $s =~ s/</&lt;/g;
+    $s =~ s/>/&gt;/g;
+    ensure_utf8($s);
+    $s;
+}
+sub encode_xml_attribute {
+    my ($s) = @_;
+
+    $s = encode_xml($s);
+
+    $s =~ /'/ or return qq('$s');
+    $s =~ /"/ or return qq("$s");
+
+    # argh!! hum replacing " with '' :-D
+    $s =~ s/"/''/g;
+    print STDERR qq(encoding xml attribute: replacing " with '' for $s\n);
+
+    qq("$s");
+}
+
 sub add_pkg {
     my ($out, $pkg) = @_;
-    add_pkg_header($out->{hdlist}, $pkg);
+    my $fullname = $pkg->fullname;
+
+    add_pkg_header($out->{hdlist}, $pkg, $fullname);
+
+    if ($out->{files}) {
+	my $F = $out->{files};
+	print $F qq(<files fn="$fullname">\n);
+	print $F encode_xml($_), "\n" foreach $pkg->files;
+	print $F qq(</files>);
+    }
+
+    if ($out->{info}) {
+	my $F = $out->{info};
+	print $F qq(<info fn="$fullname");
+	printf $F qq(\n $_=%s), encode_xml_attribute($pkg->$_) foreach qw(sourcerpm url license);
+	print $F qq(>\n);
+	print $F encode_xml($pkg->description), "\n";
+	print $F qq(</info>);
+    }
+
+    if ($out->{changelog} && $pkg->changelog_name) {
+	my $F = $out->{changelog};
+	my @ti = $pkg->changelog_time;
+	my @na = $pkg->changelog_name;
+	my @te = $pkg->changelog_text;
+
+	print $F qq(<changelogs fn="$fullname">\n);
+	foreach (0 .. $#ti) {
+	    print $F qq(<log time="$ti[$_]">\n);
+	    print $F qq(<log_name>), encode_xml($na[$_]), qq(</log_name>\n);
+	    print $F qq(<log_text>), encode_xml($te[$_]), qq(</log_text>\n);
+	    print $F qq(</log>);
+	}
+	print $F qq(</changelogs>);
+    }
 }
 
 sub add_pkg_header {
-    my ($out, $pkg) = @_;
+    my ($out, $pkg, $fullname) = @_;
     {
 	open(my $fh, ">", $tmp_header);
 	$pkg->build_header(fileno $fh);
     }
     {
 	open(my $fh, "<", $tmp_header);
-	$out->add_virtual('f', scalar($pkg->fullname), $fh);
+	$out->add_virtual('f', $fullname, $fh);
     }
     unlink $tmp_header;
 }