package urpm::dudf; # $Id: dudf.pm 639 2009-04-17 14:32:03Z orosello $ our @ISA = qw(); use strict; use Exporter; use URPM; use urpm; use urpm::msg; use urpm::util; use Cwd; use IO::File; use locale; use POSIX qw(locale_h strtod); use POSIX qw(strftime); use File::Path; use Compress::Zlib; use XML::Writer; use Data::UUID; #- Timeout for curl connection and wget operations our $CONNECT_TIMEOUT = 60; #- (in seconds) use fields qw( access_url distribution_codename distribution_description distribution_name distribution_release dudf_dir dudf_file dudf_filename dudf_time dudf_uid dudf_urpm exit_code exit_msg force_dudf installer_name installer_version log_file metainstaller_name metainstaller_version package_universe_synthesis packages_removed packages_upgraded pkgs_toinstall pkgs_user pkgs_user_install pkgs_user_upgrade version xmlns xmlnsdudf ); my @package_status; BEGIN {} (our $VERSION) = q($Revision: 246 $) =~ /(\d+)/; sub dudf_exit { my ($self, $exit_code, $o_exit_msg) = @_; $self->set_exit_code($exit_code); if ($o_exit_msg) { $self->set_exit_msg($o_exit_msg); } $self->write_dudf; exit($exit_code); } sub get_distribution { my ($self) = @_; my $handle = new IO::File; if ($handle->open(") { if (m/DISTRIB_ID=/i) { s/.*=//; s/\n//; $self->{distribution_name} = $_ } if (m/DISTRIB_RELEASE=/i) { s/.*=//; s/\n//; $self->{distribution_release} = $_ } if (m/DISTRIB_CODENAME=/i) { s/.*=//; s/\n//; $self->{distribution_codename} = $_ } if (m/DISTRIB_DESCRIPTION=/i) { s/.*=//; s///g; s/\n//; $self->{distribution_description} = $_ } } $handle->close; } } sub check_package { my ($urpm, $pkg) = @_; my $db = urpm::db_open_or_die_($urpm); my @l; $db->traverse_tag("name", [ $pkg ], sub { my ($p) = @_; $p->pack_header; push(@l, $p); }); \@l; } # Find packages selected to be removed due to obsoletes and store them into @{$self->{packages_removed}} # or due to upgrade or conflict and store them into @{$self->{packages_upgraded}} sub check_removed_upgraded { my ($self, $state) = @_; my $urpm = ${$self->{dudf_urpm}}; my $t = $state->{rejected}; foreach my $pkg (keys %$t) { my $v = $t->{$pkg}; if ($v->{obsoleted} == 1) { $pkg =~ s/-.*//; my $p = check_package($urpm,$pkg); push(@{$self->{packages_removed}}, $p); } if ($v->{removed} == 1) { $pkg =~ s/-.*//; my $p = check_package($urpm,$pkg); push(@{$self->{packages_upgraded}}, $p); } } } sub get_package_status_ { my ($ps) = @_; $ps->pack_header; push(@package_status, $ps); } # Store list of installed packages sub get_package_status { my ($self) = @_; my $db = urpm::db_open_or_die_(${$self->{dudf_urpm}}); $db->traverse(\&get_package_status_); } # Store list of synthesis files to parse sub get_package_universe { my ($self) = @_; my $urpm = ${$self->{dudf_urpm}}; @{$self->{package_universe_synthesis}} = grep { !$_->{ignore} } @{$urpm->{media}}; } # Parse a synthesis file sub get_synthesis { my ($self, $file, $doc) = @_; my $buffer; my $gz = gzopen($file, "rb"); # or die "Cannot open $file: $gzerrno\n" ; $doc->characters($buffer) while $gz->gzread($buffer) > 0; # die "Error reading from $file: $gzerrno\n" # if my $gzerrno != Z_STREAM_END ; $gz->gzclose; } sub new { my ($class, $urpm, $action, $force_dudf) = @_; my $self = { dudf_urpm => $urpm, action => $action, force_dudf => $force_dudf, dudf_file => undef, exit_code => 0, metainstaller_name => $0, metainstaller_version => $urpm::VERSION, xmlns => "http://www.mancoosi.org/2008/cudf/dudf", xmlnsdudf => "http://www.mancoosi.org/2008/cudf/dudf", version => "1.0", dudf_time => undef }; my $base_url = "http://dudf.mageia.org/"; $self->{access_url} = $base_url . "/file/"; $self->{upload_url} = $base_url . "/upload"; $self->{metainstaller_name} =~ s/.*\///; ${$self->{dudf_urpm}}->{fatal} = sub { printf STDERR "%s\n", $_[1]; $self->set_exit_msg($_[1]); $self->set_exit_code($_[0]); $self->write_dudf; exit($_[0]) }; ${$self->{dudf_urpm}}->{error} = sub { printf STDERR "%s\n", $self->set_exit_msg($_[0]); $_[0] }; #${$self->{dudf_urpm}}->{log} = sub { printf STDERR "%s\n", $_[0] }; $urpm = ${$self->{dudf_urpm}}; $self->{dudf_dir} = $urpm->{cachedir} . "/dudf"; $self->{log_file} = $self->{dudf_dir} . "/dudf_uploads.log"; if (!-d $self->{dudf_dir}) { mkpath($self->{dudf_dir}); } # If there is no log file, we create the default content here if (! -f $self->{log_file}) { output_safe($self->{log_file}, N("# Here are logs of your DUDF uploads.\n# Line format is : \n# You can use uids to see the content of your uploads at this url :\n# %s"), $base_url); } my $ug = new Data::UUID; $self->{dudf_uid} = $ug->to_string($ug->create_str); $self->{dudf_filename} = "dudf_" . $self->{dudf_uid} . ".dudf.xml"; $self->{dudf_file} = $self->{dudf_dir} . "/" . $self->{dudf_filename}; bless($self,$class); return $self; } sub set_error_msg { my ($self, $m) = @_; $self->{exit_msg} .= $m; } sub set_exit_msg { my ($self, $m) = @_; $self->{exit_msg} .= $m; } # store the exit code sub set_exit_code { my ($self, $exit_code) = @_; $self->{exit_code} = $exit_code; } # Store the list of packages the user wants to install (given to urpmi) sub store_userpkgs { my ($self, @pkgs) = @_; @{$self->{pkgs_user}} = @pkgs; } # Store a list of packages selected by urpmi to install sub store_toinstall { my ($self, @pkgs) = @_; @{$self->{pkgs_toinstall}} = @pkgs; } #upload dudf data to server sub upload_dudf { -x "/usr/bin/curl" or do { print N("curl is missing, cannot upload DUDF file.\n"); return }; my ($self, $options) = @_; print N("Compressing DUDF data... "); # gzip the file to upload open(FILE, $self->{dudf_file}) or do { print N("NOT OK\n"); return }; my $gz = gzopen($self->{dudf_file} . ".gz", "wb") or do { print N("NOT OK\n"); return }; $gz->gzsetparams(Z_BEST_COMPRESSION, Z_DEFAULT_STRATEGY); while () { $gz->gzwrite($_); } $gz->gzclose; close(FILE); print N("OK\n"); print N("Uploading DUDF data:\n"); my (@ftp_files, @other_files); push @other_files, $self->{dudf_filename}; my @l = (@ftp_files, @other_files); my $cmd = join(" ", map { "'$_'" } "/usr/bin/curl", "-q", # don't read .curlrc; some toggle options might interfer ($options->{proxy} ? urpm::download::set_proxy({ type => "curl", proxy => $options->{proxy} }) : ()), ($options->{retry} ? ('--retry', $options->{retry}) : ()), "--stderr", "-", # redirect everything to stdout "--connect-timeout", $CONNECT_TIMEOUT, # "-s", "-f", "--anyauth", (defined $options->{'curl-options'} ? split /\s+/, $options->{'curl-options'} : ()), "-F file=@" . $self->{dudf_file} . ".gz", "-F id=" . $self->{dudf_uid}, $self->{upload_url}, ); urpm::download::_curl_action($cmd, $options, @l, 1); unlink $self->{dudf_file} . ".gz"; unlink $self->{dudf_file}; print N("\nYou can see your DUDF report at the following URL :\n\t"); print $self->{access_url} . "?uid=" . $self->{dudf_uid} . "\n"; append_to_file($self->{log_file}, $self->{dudf_time} . "\t" . $self->{dudf_uid} . "\n"); print N("You can access a log of your uploads in\n\t") . $self->{log_file} . "\n"; } sub xml_pkgs { my ($doc, $pk) = @_; if ($pk->epoch) { $doc->startTag("package", "name" => $pk->name, "version" => $pk->version, "arch" => $pk->arch, "release" => $pk->release, "epoch" => $pk->epoch); } else { $doc->startTag("package", "name" => $pk->name, "version" => $pk->version, "arch" => $pk->arch, "release" => $pk->release); } if ($pk->provides) { $doc->startTag("provides"); foreach my $i ($pk->provides) { $doc->characters("@" . $i); } $doc->endTag; } if ($pk->requires) { $doc->startTag("requires"); foreach my $i ($pk->requires) { $doc->characters("@" . $i); } $doc->endTag; } if ($pk->conflicts) { $doc->startTag("conflicts"); foreach my $i ($pk->conflicts) { $doc->characters("@" . $i); } $doc->endTag; } if ($pk->obsoletes) { $doc->startTag("obsoletes"); foreach my $i ($pk->obsoletes) { $doc->characters("@" . $i); } $doc->endTag; } $doc->endTag; } sub compute_pkgs_user { my ($self) = @_; my $in; foreach my $p (@{$self->{pkgs_user}}) { $in = 0; foreach my $pk (@package_status) { # packages installed by urpmi are removed from the list if (@{$self->{pkgs_toinstall}}) { foreach my $pkg (@{$self->{pkgs_toinstall}}) { if ($p eq $pk->name) { if (($pkg->name ne $pk->name || $pkg->version ne $pk->version || $pkg->arch ne $pk->arch || $pkg->release ne $pk->release || $pkg->epoch ne $pk->epoch)) { $in = 1; if (!grep($p, @{$self->{pkgs_user_upgrade}})) { push(@{$self->{pkgs_user_upgrade}}, $p); } } } } } } if (($in == 0) && (!grep($p, @{$self->{pkgs_user_install}}))) { push(@{$self->{pkgs_user_install}}, $p); } } } # Generate DUDF data sub write_dudf { my ($self) = @_; if ( (!${$self->{dudf_urpm}}->{options}{auto}) && ( ($self->{exit_code} > 9) || (!$self->{exit_code} && $self->{force_dudf}) ) ) { my $noexpr = N("Nn"); my $msg = N("A problem has been encountered. You can help Mandriva to improve package\ninstallation by uploading a DUDF report file.\nThis is a part of the Mancoosi european research project.\nMore at http://www.mancoosi.org\n"); $msg .= N("Do you want to upload a DUDF report to Mandriva?"); if ($self->{force_dudf} || message_input_($msg . N(" (Y/n) "), boolean => 1) !~ /[$noexpr]/) { print N("\nGenerating DUDF... "); urpm::db_open_or_die(urpm->new)->traverse_tag("name", [ "rpm" ], sub { my ($p) = @_; $self->{installer_name} = $p->name; $self->{installer_version} = $p->version }); $self->get_package_status; $self->get_package_universe; $self->compute_pkgs_user; my $output = new IO::File; if ($output->open(">" . $self->{dudf_file})) { my $doc = new XML::Writer(OUTPUT => $output, DATA_MODE => 1, DATA_INDENT => 1, NEW_LINES => 1, ENCODING => 'utf-8'); $doc->xmlDecl("UTF-8"); $self->get_distribution; my $old_locale = setlocale(LC_CTYPE); setlocale(LC_TIME, "C"); my $now = time(); $doc->startTag("dudf", version => $self->{version}, xmlns => $self->{xmlns}, "xmlns:dudf" => $self->{xmlnsdudf}); $doc->dataElement(timestamp => strftime("%a, %d %b %Y %H:%M:%S %z", localtime($now))); $self->{dudf_time} = strftime("%Y%m%d %H:%M:%S %z", localtime($now)); setlocale(LC_CTYPE, $old_locale); # From here, the indent is special : a new ident is made for each XML tag opening # It's easier to debug XML with this $doc->dataElement(uid => $self->{dudf_uid}); $doc->startTag("distribution"); $doc->characters($self->{distribution_name}); # Following lines removed because these elements are not specified into dudf for now (leave comment in code for future usage) # $doc->dataElement(name => "$self->{distribution_name}"); # $doc->dataElement(release => "$self->{distribution_release}"); # $doc->dataElement(codename => "$self->{distribution_codename}"); # $doc->dataElement(description => "$self->{distribution_description}"); $doc->endTag; $doc->startTag("installer"); $doc->dataElement(name => $self->{installer_name}); $doc->dataElement(version => $self->{installer_version}); $doc->endTag; $doc->startTag("meta-installer"); $doc->dataElement(name => $self->{metainstaller_name}); $doc->dataElement(version => $self->{metainstaller_version}); $doc->endTag; $doc->startTag("problem"); $doc->startTag("package-status"); $doc->startTag("installer"); # packages removed by urpmi are added back foreach my $pkg (@{$self->{packages_removed}}) { foreach my $pk (@$pkg) { xml_pkgs($doc,$pk); } } # packages upgraded by urpmi are restored in the list (version before upgrade) foreach my $pkg (@{$self->{packages_upgraded}}) { foreach my $pk (@$pkg) { xml_pkgs($doc,$pk); } } # packages already installed before the launch of urpmi foreach my $pk (@package_status) { # packages installed by urpmi are removed from the list if (@{$self->{pkgs_toinstall}}) { foreach my $pkg (@{$self->{pkgs_toinstall}}) { if (($pkg->name ne $pk->name || $pkg->version ne $pk->version || $pkg->arch ne $pk->arch || $pkg->release ne $pk->release || $pkg->epoch ne $pk->epoch)) { xml_pkgs($doc,$pk); } } } else { xml_pkgs($doc,$pk); } } $doc->endTag; $doc->dataElement("meta-installer" => "meta installer package status"); $doc->endTag; $doc->startTag("package-universe"); foreach my $media (@{$self->{package_universe_synthesis}}) { my $file = $media->{name}; my $url = $media->{url}; my $filename = urpm::media::any_synthesis(${$self->{dudf_urpm}},$media); $doc->startTag("package-list", "dudf:format" => "synthesis", "dudf:filetype" => $file, "dudf:filename" => $filename, "dudf:url" => $url); $self->get_synthesis($filename, $doc); $doc->endTag; } $doc->endTag; $doc->startTag("action"); $doc->startTag("upgrade"); foreach my $pkg (@{$self->{pkgs_user_upgrade}}) { $doc->startTag("package", "name" => $pkg); $doc->endTag; } $doc->endTag; $doc->startTag("install"); foreach my $pkg (@{$self->{pkgs_user_install}}) { $doc->startTag("package", "name" => $pkg); $doc->endTag; } $doc->endTag; $doc->startTag("command"); $doc->characters($self->{action}); $doc->endTag; $doc->endTag; $doc->startTag("desiderata"); $doc->endTag; $doc->endTag; $doc->startTag("outcome"); $doc->startTag("dudf:result"); $doc->characters(($self->{exit_code} == 0 ? "success" : "failure")); $doc->endTag; if ($self->{exit_code}) { $doc->startTag("error"); $doc->characters($self->{exit_msg}); $doc->endTag; } $doc->endTag; $doc->endTag; $doc->end; $output->close; print N("OK\n"); $self->upload_dudf; } else { print N("Cannot write DUDF file.\n"); } } } } 1; __END__