PageRenderTime 59ms CodeModel.GetById 22ms RepoModel.GetById 0ms app.codeStats 1ms

/IronPython_Main/Runtime/Tests/LinqDlrTests/testenv/perl/site/lib/PPM.pm

#
Perl | 2093 lines | 1673 code | 232 blank | 188 comment | 291 complexity | dbc4590115411b0e1201518335b435ca MD5 | raw file
Possible License(s): GPL-2.0, MPL-2.0-no-copyleft-exception, CPL-1.0, CC-BY-SA-3.0, BSD-3-Clause, ISC, AGPL-3.0, LGPL-2.1, Apache-2.0

Large files files are truncated, but you can click here to view the full file

  1. package PPM;
  2. require 5.004;
  3. require Exporter;
  4. @ISA = qw(Exporter);
  5. @EXPORT = qw(PPMdat PPMERR InstalledPackageProperties ListOfRepositories
  6. RemoveRepository AddRepository GetPPMOptions SetPPMOptions InstallPackage
  7. RemovePackage VerifyPackage UpgradePackage RepositoryPackages
  8. RepositoryPackageProperties QueryInstalledPackages
  9. RepositorySummary ServerSearch PPMShell);
  10. use LWP::UserAgent;
  11. use LWP::Simple;
  12. use File::Basename;
  13. use File::Copy;
  14. use File::Path;
  15. use ExtUtils::Install;
  16. use Cwd;
  17. use Config;
  18. use PPM::RelocPerl;
  19. use SOAP::Lite;
  20. use PPM::XML::PPD;
  21. use PPM::XML::PPMConfig;
  22. use XML::Parser;
  23. use Archive::Tar;
  24. use strict;
  25. my $useDocTools; # Generate HTML documentation after installing a package
  26. BEGIN {
  27. if (eval "require ActivePerl::DocTools") {
  28. import ActivePerl::DocTools;
  29. $useDocTools++;
  30. }
  31. }
  32. #set Debug to 1 to debug PPMdat file reading
  33. # 2 to debug parsing PPDs
  34. #
  35. # values may be or'ed together.
  36. #
  37. my $Debug = 0;
  38. my ($PPMERR, $PPM_ver, $CPU, $OS_VALUE, $OS_VERSION, $LANGUAGE);
  39. # options from data file.
  40. my %options;
  41. my $TraceStarted = 0;
  42. # true if we're running from ppm, as opposed to VPM, etc.
  43. my $PPMShell;
  44. my %repositories;
  45. my %cached_ppd_list;
  46. # Keys for this hash are package names. It is filled in by a successful
  47. # call to read_config(). Each package is a hash with the following keys:
  48. # LOCATION, INST_DATE, INST_ROOT, INST_PACKLIST and INST_PPD.
  49. my %installed_packages = ();
  50. # Keys for this hash are CODEBASE, INSTALL_HREF, INSTALL_EXEC,
  51. # INSTALL_SCRIPT, NAME, VERSION, TITLE, ABSTRACT, LICENSE, AUTHOR,
  52. # UNINSTALL_HREF, UNINSTALL_EXEC, UNINSTALL_SCRIPT, PERLCORE_VER and DEPEND.
  53. # It is filled in after a successful call to parsePPD().
  54. my %current_package = ();
  55. my @current_package_stack;
  56. # this may get overridden by the config file.
  57. my @required_packages = qw(PPM SOAP-Lite libnet Archive-Tar Compress-Zlib
  58. libwww-perl XML-Parser);
  59. # Packages that can't be upgraded on Win9x
  60. my @Win9x_denied = qw(xml-parser compress-zlib);
  61. my %Win9x_denied;
  62. @Win9x_denied{@Win9x_denied} = ();
  63. # ppm.xml location is in the environment variable 'PPM_DAT', else it is in
  64. # [Perl]/site/lib, else it is in the same place as this script.
  65. my ($basename, $path) = fileparse($0);
  66. if (defined $ENV{'PPM_DAT'} && -f $ENV{'PPM_DAT'})
  67. {
  68. $PPM::PPMdat = $ENV{'PPM_DAT'};
  69. }
  70. elsif (-f "$Config{'installsitelib'}/ppm.xml")
  71. {
  72. $PPM::PPMdat = "$Config{'installsitelib'}/ppm.xml";
  73. }
  74. elsif (-f "$Config{'installprivlib'}/ppm.xml")
  75. {
  76. $PPM::PPMdat = "$Config{'installprivlib'}/ppm.xml";
  77. }
  78. elsif (-f $path . "/ppm.xml")
  79. {
  80. $PPM::PPMdat = $path . $PPM::PPMdat;
  81. }
  82. else
  83. {
  84. &Trace("Failed to load PPM_DAT file") if $options{'TRACE'};
  85. print "Failed to load PPM_DAT file\n";
  86. return -1;
  87. }
  88. &Trace("Using config file: $PPM::PPMdat") if $options{'TRACE'};
  89. my $init = 0;
  90. chmod(0644, $PPM::PPMdat);
  91. #
  92. # Exported subs
  93. #
  94. sub InstalledPackageProperties
  95. {
  96. my %ret_hash;
  97. read_config();
  98. foreach (keys %installed_packages) {
  99. parsePPD(%{ $installed_packages{$_}{'INST_PPD'} } );
  100. $ret_hash{$_}{'NAME'} = $_;
  101. $ret_hash{$_}{'DATE'} = $installed_packages{$_}{'INST_DATE'};
  102. $ret_hash{$_}{'TITLE'} = $current_package{'TITLE'};
  103. $ret_hash{$_}{'AUTHOR'} = $current_package{'AUTHOR'};
  104. $ret_hash{$_}{'VERSION'} = $current_package{'VERSION'};
  105. $ret_hash{$_}{'ABSTRACT'} = $current_package{'ABSTRACT'};
  106. $ret_hash{$_}{'PERLCORE_VER'} = $current_package{'PERLCORE_VER'};
  107. foreach my $dep (keys %{$current_package{'DEPEND'}}) {
  108. push @{$ret_hash{$_}{'DEPEND'}}, $dep;
  109. }
  110. }
  111. return %ret_hash;
  112. }
  113. sub ListOfRepositories
  114. {
  115. my %reps;
  116. read_config();
  117. foreach (keys %repositories) {
  118. $reps{$_} = $repositories{$_}{'LOCATION'};
  119. }
  120. return %reps;
  121. }
  122. sub RemoveRepository
  123. {
  124. my %argv = @_;
  125. my $repository = $argv{'repository'};
  126. my $save = $argv{'save'};
  127. read_config();
  128. foreach (keys %repositories) {
  129. if ($_ =~ /^\Q$repository\E$/) {
  130. &Trace("Removed repository $repositories{$repository}")
  131. if $options{'TRACE'};
  132. delete $repositories{$repository};
  133. last;
  134. }
  135. }
  136. save_options() if $save;
  137. }
  138. sub AddRepository
  139. {
  140. my %argv = @_;
  141. my $repository = $argv{'repository'};
  142. my $save = $argv{'save'};
  143. my $location = $argv{'location'};
  144. my $username = $argv{'username'};
  145. my $password = $argv{'password'};
  146. read_config();
  147. $repositories{$repository}{'LOCATION'} = $location;
  148. $repositories{$repository}{'USERNAME'} = $username if defined $username;
  149. $repositories{$repository}{'PASSWORD'} = $password if defined $password;
  150. &Trace("Added repository $location") if $options{'TRACE'};
  151. save_options() if $save;
  152. }
  153. sub GetPPMOptions
  154. {
  155. read_config();
  156. return %options;
  157. }
  158. sub SetPPMOptions
  159. {
  160. my %argv = @_;
  161. %options = %{$argv{'options'}};
  162. save_options() if $argv{'save'};
  163. }
  164. sub UpgradePackage
  165. {
  166. my %argv = @_;
  167. my $package = $argv{'package'};
  168. my $location = $argv{'location'};
  169. return VerifyPackage("package" => $package, "location" => $location,
  170. "upgrade" => 1);
  171. }
  172. # Returns 1 on success, 0 and sets $PPMERR on failure.
  173. sub InstallPackage
  174. {
  175. my %argv = @_;
  176. my $package = $argv{'package'};
  177. my $location = $argv{'location'};
  178. my $root = $argv{'root'} || $options{'ROOT'} || undef;
  179. my ($PPDfile, %PPD);
  180. read_config();
  181. if (!defined($package) && -d "blib" && -f "Makefile") {
  182. unless (open MAKEFILE, "< Makefile") {
  183. $PPM::PPMERR = "Couldn't open Makefile for reading: $!";
  184. return 0;
  185. }
  186. while (<MAKEFILE>) {
  187. if (/^DISTNAME\s*=\s*(\S+)/) {
  188. $package = $1;
  189. $PPDfile = "$1.ppd";
  190. last;
  191. }
  192. }
  193. close MAKEFILE;
  194. unless (defined $PPDfile) {
  195. $PPM::PPMERR = "Couldn't determine local package name";
  196. return 0;
  197. }
  198. system("$Config{make} ppd");
  199. # XXX should set $PPM::PPMERR?
  200. return 0 unless (%PPD = getPPDfile('package' => $PPDfile));
  201. parsePPD(%PPD);
  202. $options{'CLEAN'} = 0;
  203. goto InstallBlib;
  204. }
  205. unless (%PPD = getPPDfile('package' => $package,
  206. 'location' => $location, 'PPDfile' => \$PPDfile)) {
  207. &Trace("Could not locate a PPD file for package $package")
  208. if $options{'TRACE'};
  209. $PPM::PPMERR = "Could not locate a PPD file for package $package";
  210. return 0;
  211. }
  212. if ($Config{'osname'} eq 'MSWin32' &&
  213. !&Win32::IsWinNT && exists $Win9x_denied{lc($package)}) {
  214. $PPM::PPMERR = "Package '$package' cannot be installed with PPM on Win9x--see http://www.ActiveState.com/ppm for details";
  215. return 0;
  216. }
  217. parsePPD(%PPD);
  218. if (!$current_package{'CODEBASE'} && !$current_package{'INSTALL_HREF'}) {
  219. &Trace("Read a PPD for '$package', but it is not intended for this build of Perl ($Config{archname})")
  220. if $options{'TRACE'};
  221. $PPM::PPMERR = "Read a PPD for '$package', but it is not intended for this build of Perl ($Config{archname})";
  222. return 0;
  223. }
  224. if (defined $current_package{'DEPEND'}) {
  225. push(@current_package_stack, [%current_package]);
  226. foreach my $dep (keys %{$current_package{'DEPEND'}}) {
  227. # Has PPM already installed it?
  228. unless ($installed_packages{$dep}) {
  229. # Has *anybody* installed it, or is it part of core Perl?
  230. my $p = $dep;
  231. $p =~ s@-@/@g;
  232. my $found = grep -f, map "$_/$p.pm", @INC;
  233. unless ($found) {
  234. &Trace("Installing dependency '$dep'...")
  235. if $options{'TRACE'};
  236. unless (!InstallPackage("package" => $dep,
  237. "location" => $location)) {
  238. &Trace("Error installing dependency: $PPM::PPMERR")
  239. if $options{'TRACE'};
  240. $PPM::PPMERR = "Error installing dependency: $PPM::PPMERR\n";
  241. return 0 unless ($options{'FORCE_INSTALL'});
  242. }
  243. }
  244. }
  245. # make sure minimum version is installed, if necessary
  246. elsif (defined $current_package{'DEPEND'}{$dep}) {
  247. my @comp = split (',', $current_package{'DEPEND'}{$dep});
  248. # parsePPD fills in %current_package
  249. push(@current_package_stack, [%current_package]);
  250. parsePPD(%{$installed_packages{$dep}{'INST_PPD'}});
  251. my @inst = split (',', $current_package{'VERSION'});
  252. foreach(0..3) {
  253. if ($comp[$_] > $inst[$_]) {
  254. VerifyPackage("package" => $dep, "upgrade" => 1);
  255. last;
  256. }
  257. last if ($comp[$_] < $inst[$_]);
  258. }
  259. %current_package = @{pop @current_package_stack};
  260. }
  261. }
  262. %current_package = @{pop @current_package_stack};
  263. }
  264. my ($basename, $path) = fileparse($PPDfile);
  265. # strip the trailing path separator
  266. my $chr = substr($path, -1, 1);
  267. chop $path if ($chr eq '/' || $chr eq '\\');
  268. if ($path =~ /^file:\/\/.*\|/i) {
  269. # $path is a local directory, let's avoid LWP by changing
  270. # it to a pathname.
  271. $path =~ s@^file://@@i;
  272. $path =~ s@^localhost/@@i;
  273. $path =~ s@\|@:@;
  274. }
  275. # get the code and put it in build_dir
  276. my $install_dir = "$options{'BUILDDIR'}/$current_package{'NAME'}-$$";
  277. File::Path::rmtree($install_dir,0,0);
  278. unless (-d $install_dir || File::Path::mkpath($install_dir, 0, 0755)) {
  279. &Trace("Could not create $install_dir: $!") if $options{'TRACE'};
  280. $PPM::PPMERR = "Could not create $install_dir: $!";
  281. return 0;
  282. }
  283. $basename = fileparse($current_package{'CODEBASE'});
  284. # CODEBASE is a URL
  285. if ($current_package{'CODEBASE'} =~ m@^...*://@i) {
  286. return 0 unless read_href('href' => "$current_package{'CODEBASE'}",
  287. 'target' => "$install_dir/$basename", 'request' => "GET",
  288. 'progress' => 1);
  289. }
  290. # CODEBASE is a full pathname
  291. elsif (-f $current_package{'CODEBASE'}) {
  292. &Trace("Copying $current_package{'CODEBASE'} to $install_dir/$basename")
  293. if $options{'TRACE'} > 1;
  294. copy($current_package{'CODEBASE'}, "$install_dir/$basename");
  295. }
  296. # CODEBASE is relative to the directory location of the PPD
  297. elsif (-f "$path/$current_package{'CODEBASE'}") {
  298. &Trace("Copying $path/$current_package{'CODEBASE'} to $install_dir/$basename") if $options{'TRACE'} > 1;
  299. copy("$path/$current_package{'CODEBASE'}", "$install_dir/$basename");
  300. }
  301. # CODEBASE is relative to the URL location of the PPD
  302. else {
  303. return 0 unless read_href('target' => "$install_dir/$basename",
  304. 'href' => "$path/$current_package{'CODEBASE'}",
  305. 'request' => 'GET', 'progress' => 1);
  306. }
  307. my $cwd = getcwd();
  308. $cwd .= "/" if $cwd =~ /[a-z]:$/i;
  309. chdir($install_dir);
  310. my $tar;
  311. if ($basename =~ /\.gz$/i) {
  312. $tar = Archive::Tar->new($basename,1);
  313. }
  314. else {
  315. $tar = Archive::Tar->new($basename,0);
  316. }
  317. $tar->extract($tar->list_files);
  318. $basename =~ /(.*).tar/i;
  319. chdir($1);
  320. RelocPerl('.') if ($Config{'osname'} ne 'MSWin32');
  321. InstallBlib:
  322. my $inst_archlib = $Config{installsitearch};
  323. my $inst_root = $Config{prefix};
  324. my $packlist = MM->catfile("$Config{installsitearch}/auto",
  325. split(/-/, $current_package{'NAME'}), ".packlist");
  326. # copied from ExtUtils::Install
  327. my $INST_LIB = MM->catdir(MM->curdir,"blib","lib");
  328. my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch");
  329. my $INST_BIN = MM->catdir(MM->curdir,'blib','bin');
  330. my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script');
  331. my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1');
  332. my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3');
  333. my $INST_HTMLDIR = MM->catdir(MM->curdir,'blib','html');
  334. my $INST_HTMLHELPDIR = MM->catdir(MM->curdir,'blib','htmlhelp');
  335. my $inst_script = $Config{installscript};
  336. my $inst_man1dir = $Config{installman1dir};
  337. my $inst_man3dir = $Config{installman3dir};
  338. my $inst_bin = $Config{installbin};
  339. my $inst_htmldir = $Config{installhtmldir};
  340. my $inst_htmlhelpdir = $Config{installhtmlhelpdir};
  341. my $inst_lib = $Config{installsitelib};
  342. if (defined $root && $root !~ /^\Q$inst_root\E$/i) {
  343. $packlist =~ s/\Q$inst_root/$root\E/i;
  344. $inst_lib =~ s/\Q$inst_root/$root\E/i;
  345. $inst_archlib =~ s/\Q$inst_root/$root\E/i;
  346. $inst_bin =~ s/\Q$inst_root/$root\E/i;
  347. $inst_script =~ s/\Q$inst_root/$root\E/i;
  348. $inst_man1dir =~ s/\Q$inst_root/$root\E/i;
  349. $inst_man3dir =~ s/\Q$inst_root/$root\E/i;
  350. $inst_root = $root;
  351. }
  352. while (1) {
  353. my $cwd = getcwd();
  354. $cwd .= "/" if $cwd =~ /[a-z]:$/i;
  355. &Trace("Calling ExtUtils::Install::install") if $options{'TRACE'} > 1;
  356. eval {
  357. ExtUtils::Install::install({
  358. "read" => $packlist, "write" => $packlist,
  359. $INST_LIB => $inst_lib, $INST_ARCHLIB => $inst_archlib,
  360. $INST_BIN => $inst_bin, $INST_SCRIPT => $inst_script,
  361. $INST_MAN1DIR => $inst_man1dir, $INST_MAN3DIR => $inst_man3dir,
  362. $INST_HTMLDIR => $inst_htmldir,
  363. $INST_HTMLHELPDIR => $inst_htmlhelpdir},0,0,0);
  364. };
  365. # install might have croaked in another directory
  366. chdir($cwd);
  367. # Can't remove some DLLs, but we can rename them and try again.
  368. if ($@ && $@ =~ /Cannot forceunlink (\S+)/) {
  369. &Trace("$@...attempting rename") if $options{'TRACE'};
  370. my $oldname = $1;
  371. $oldname =~ s/:$//;
  372. my $newname = $oldname . "." . time();
  373. unless (rename($oldname, $newname)) {
  374. &Trace("$!") if $options{'TRACE'};
  375. $PPM::PPMERR = "$!";
  376. return 0;
  377. }
  378. }
  379. # Some other error
  380. elsif($@) {
  381. &Trace("$@") if $options{'TRACE'};
  382. $PPM::PPMERR = $@;
  383. return 0;
  384. }
  385. else { last; }
  386. }
  387. #rebuild the html TOC
  388. Trace("Calling ActivePerl::DocTools::WriteTOC()") if $options{'TRACE'} > 1;
  389. ActivePerl::DocTools::WriteTOC() if $useDocTools;
  390. if (defined $current_package{'INSTALL_SCRIPT'}) {
  391. run_script("script" => $current_package{'INSTALL_SCRIPT'},
  392. "scriptHREF" => $current_package{'INSTALL_HREF'},
  393. "exec" => $current_package{'INSTALL_EXEC'},
  394. "inst_root" => $inst_root, "inst_archlib" => $inst_archlib);
  395. }
  396. chdir($cwd);
  397. # ask to store this location as default for this package?
  398. PPMdat_add_package($path, $packlist, $inst_root);
  399. # if 'install.ppm' exists, don't remove; system()
  400. # has probably not finished with it yet.
  401. if ($options{'CLEAN'} && !-f "$install_dir/install.ppm") {
  402. File::Path::rmtree($install_dir,0,0);
  403. }
  404. &Trace("Package $package successfully installed") if $options{'TRACE'};
  405. reread_config();
  406. return 1;
  407. }
  408. # Returns a hash with key $location, and elements of arrays of package names.
  409. # Uses '%repositories' if $location is not specified.
  410. sub RepositoryPackages
  411. {
  412. my %argv = @_;
  413. my $location = $argv{'location'};
  414. my %ppds;
  415. if (defined $location) {
  416. @{$ppds{$location}} = list_available("location" => $location);
  417. unless (@{$ppds{$location}}) {
  418. print "Error connecting to '$location'.\n";
  419. }
  420. }
  421. else {
  422. read_config(); # need repositories
  423. foreach (keys %repositories) {
  424. $location = $repositories{$_}{'LOCATION'};
  425. @{$ppds{$location}} = list_available("location" => $location);
  426. }
  427. }
  428. return %ppds;
  429. }
  430. sub RepositoryPackageProperties
  431. {
  432. my %argv = @_;
  433. my $location = $argv{'location'};
  434. my $package = $argv{'package'};
  435. my %PPD;
  436. read_config();
  437. unless (%PPD = getPPDfile('package' => $package, 'location' => $location)) {
  438. &Trace("RepositoryPackageProperties: Could not locate a PPD file for package $package") if $options{'TRACE'};
  439. $PPM::PPMERR = "Could not locate a PPD file for package $package";
  440. return;
  441. }
  442. parsePPD(%PPD);
  443. my %ret_hash = map { $_ => $current_package{$_} }
  444. qw(NAME TITLE AUTHOR VERSION ABSTRACT PERLCORE_VER);
  445. foreach my $dep (keys %{$current_package{'DEPEND'}}) {
  446. push @{$ret_hash{'DEPEND'}}, $dep;
  447. }
  448. return %ret_hash;
  449. }
  450. # Returns 1 on success, 0 and sets $PPMERR on failure.
  451. sub RemovePackage
  452. {
  453. my %argv = @_;
  454. my $package = $argv{'package'};
  455. my $force = $argv{'force'};
  456. my %PPD;
  457. read_config();
  458. unless ($installed_packages{$package}) {
  459. my $pattern = $package;
  460. undef $package;
  461. # Do another lookup, ignoring case
  462. foreach (keys %installed_packages) {
  463. if (/^$pattern$/i) {
  464. $package = $_;
  465. last;
  466. }
  467. }
  468. unless ($package) {
  469. &Trace("Package '$pattern' has not been installed by PPM")
  470. if $options{'TRACE'};
  471. $PPM::PPMERR = "Package '$pattern' has not been installed by PPM";
  472. return 0;
  473. }
  474. }
  475. # Don't let them remove PPM itself, libnet, Archive-Tar, etc.
  476. # but we can force removal if we're upgrading
  477. unless ($force) {
  478. foreach (@required_packages) {
  479. if ($_ eq $package) {
  480. &Trace("Package '$package' is required by PPM and cannot be removed") if $options{'TRACE'};
  481. $PPM::PPMERR = "Package '$package' is required by PPM and cannot be removed";
  482. return 0;
  483. }
  484. }
  485. }
  486. my $install_dir = "$options{'BUILDDIR'}/$package";
  487. %PPD = %{ $installed_packages{$package}{'INST_PPD'} };
  488. parsePPD(%PPD);
  489. my $cwd = getcwd();
  490. $cwd .= "/" if $cwd =~ /[a-z]:$/i;
  491. if (defined $current_package{'UNINSTALL_SCRIPT'}) {
  492. if (!chdir($install_dir)) {
  493. &Trace("Could not chdir() to $install_dir: $!") if $options{'TRACE'};
  494. $PPM::PPMERR = "Could not chdir() to $install_dir: $!";
  495. return 0;
  496. }
  497. run_script("script" => $current_package{'UNINSTALL_SCRIPT'},
  498. "scriptHREF" => $current_package{'UNINSTALL_HREF'},
  499. "exec" => $current_package{'UNINSTALL_EXEC'});
  500. chdir($cwd);
  501. }
  502. else {
  503. if (-f $installed_packages{$package}{'INST_PACKLIST'}) {
  504. &Trace("Calling ExtUtils::Install::uninstall")
  505. if $options{'TRACE'} > 1;
  506. eval {
  507. ExtUtils::Install::uninstall("$installed_packages{$package}{'INST_PACKLIST'}", 0, 0);
  508. };
  509. warn $@ if $@;
  510. }
  511. }
  512. #rebuild the html TOC
  513. Trace("Calling ActivePerl::DocTools::WriteTOC()") if $options{'TRACE'} > 1;
  514. ActivePerl::DocTools::WriteTOC() if $useDocTools;
  515. File::Path::rmtree($install_dir,0,0);
  516. PPMdat_remove_package($package);
  517. &Trace("Package $package removed") if $options{'TRACE'};
  518. reread_config();
  519. return 1;
  520. }
  521. # returns "0" if package is up-to-date; "1" if an upgrade is available;
  522. # undef and sets $PPMERR on error; and the new VERSION string if a package
  523. # was upgraded.
  524. sub VerifyPackage
  525. {
  526. my %argv = @_;
  527. my $package = $argv{'package'};
  528. my $location = $argv{'location'};
  529. my $upgrade = $argv{'upgrade'};
  530. my $force = $argv{'force'};
  531. my ($installedPPDfile, $comparePPDfile, %installedPPD, %comparePPD);
  532. read_config();
  533. unless ($installed_packages{$package}) {
  534. my $pattern = $package;
  535. undef $package;
  536. # Do another lookup, ignoring case
  537. foreach (keys %installed_packages) {
  538. if (/^$pattern$/i) {
  539. $package = $_;
  540. last;
  541. }
  542. }
  543. unless ($package) {
  544. &Trace("Package '$pattern' has not been installed by PPM") if $options{'TRACE'};
  545. $PPM::PPMERR = "Package '$pattern' has not been installed by PPM";
  546. return undef;
  547. }
  548. }
  549. %installedPPD = %{ $installed_packages{$package}{'INST_PPD'} };
  550. unless (%comparePPD = getPPDfile('package' => $package,
  551. 'location' => $location)) {
  552. &Trace("VerifyPackage: Could not locate a PPD file for $package")
  553. if $options{'TRACE'};
  554. $PPM::PPMERR = "Could not locate a PPD file for $package";
  555. return;
  556. }
  557. parsePPD(%installedPPD);
  558. my @installed_version = split (',', $current_package{'VERSION'});
  559. my $inst_root = $installed_packages{$package}{'INST_ROOT'};
  560. parsePPD(%comparePPD);
  561. unless ($current_package{'CODEBASE'} || $current_package{'INSTALL_HREF'}) {
  562. &Trace("Read a PPD for '$package', but it is not intended for this build of Perl ($Config{archname})")
  563. if $options{'TRACE'};
  564. $PPM::PPMERR = "Read a PPD for '$package', but it is not intended for this build of Perl ($Config{archname})";
  565. return undef;
  566. }
  567. my @compare_version = split (',', $current_package{'VERSION'});
  568. my $available;
  569. foreach(0..3) {
  570. next if $installed_version[$_] == $compare_version[$_];
  571. $available++ if $installed_version[$_] < $compare_version[$_];
  572. last;
  573. }
  574. if ($available || $force) {
  575. &Trace("Upgrade to $package is available")
  576. if $options{'TRACE'} > 1 and $available;
  577. if ($upgrade) {
  578. if ($Config{'osname'} eq 'MSWin32' &&
  579. !&Win32::IsWinNT && exists $Win9x_denied{lc($package)}) {
  580. $PPM::PPMERR = "Package '$package' cannot be upgraded with PPM on Win9x--see http://aspn.ActiveState.com/ASPN/Downloads/ActivePerl/PPM/ for details";
  581. return undef;
  582. }
  583. # need to remember the $location, and $current_version,
  584. # because once we remove the package, they're unavailable.
  585. # XXX this should probably be fixed
  586. $location = $installed_packages{$package}{'LOCATION'} unless $location;
  587. my $current_version = $current_package{'VERSION'};
  588. unless (getPPDfile('package' => $package,
  589. 'location' => $location)) {
  590. &Trace("VerifyPackage: Could not locate a PPD file for $package") if $options{'TRACE'};
  591. $PPM::PPMERR = "Could not locate a PPD file for $package";
  592. return undef;
  593. }
  594. RemovePackage("package" => $package, "force" => 1);
  595. unless(InstallPackage("package" => $package,
  596. "location" => $location,
  597. "root" => $inst_root))
  598. {
  599. # InstallPackage() sets $PPM::PPMERR if it fails
  600. return undef;
  601. }
  602. return $current_version;
  603. }
  604. return 1;
  605. }
  606. # package is up to date
  607. return 0;
  608. }
  609. # Changes where the packages are installed.
  610. # Returns previous root on success, undef and sets $PPMERR on failure.
  611. sub chroot
  612. {
  613. my %argv = @_;
  614. my $location = $argv{'location'};
  615. unless (-d $location) {
  616. &Trace("'$location' does not exist.") if $options{'TRACE'};
  617. $PPM::PPMERR = "'$location' does not exist.\n";
  618. return undef;
  619. }
  620. my $previous_root = $options{'ROOT'} || $Config{'prefix'};
  621. $options{'ROOT'} = $location;
  622. return $previous_root;
  623. }
  624. sub QueryInstalledPackages
  625. {
  626. my %argv = @_;
  627. my $ignorecase = $options{'IGNORECASE'} || $argv{'ignorecase'};
  628. my $searchtag = uc $argv{'searchtag'} || undef;
  629. my ($searchRE, $package, %ret_hash);
  630. if (defined $argv{'searchRE'}) {
  631. $searchRE = $argv{'searchRE'};
  632. $searchRE = "(?i)$searchRE" if $ignorecase;
  633. eval { $searchRE =~ /$searchRE/ };
  634. if ($@) {
  635. &Trace("'$searchRE': invalid regular expression.") if $options{'TRACE'};
  636. $PPM::PPMERR = "'$searchRE': invalid regular expression.";
  637. return ();
  638. }
  639. }
  640. read_config();
  641. foreach $package (keys %installed_packages) {
  642. my $results = $package;
  643. if (defined $searchtag) {
  644. my %Package = %{ $installed_packages{$package} };
  645. parsePPD( %{ $Package{'INST_PPD'} } );
  646. $results = $current_package{$searchtag};
  647. }
  648. $ret_hash{$package} = $results
  649. if (!defined $searchRE || ($results =~ /$searchRE/));
  650. }
  651. return %ret_hash;
  652. }
  653. # Returns a summary of available packages for all repositories.
  654. # Returned hash has the following structure:
  655. #
  656. # $hash{repository}{package_name}{NAME}
  657. # $hash{repository}{package_name}{VERSION}
  658. # etc.
  659. #
  660. sub RepositorySummary {
  661. my %argv = @_;
  662. my $location = $argv{'location'};
  663. my (%summary, %locations);
  664. # If we weren't given the location of a repository to query the summary
  665. # for, check all of the repositories that we know about.
  666. unless ($location) {
  667. read_config(); # need repositories
  668. foreach (keys %repositories) {
  669. $locations{$repositories{$_}{'LOCATION'}} =
  670. $repositories{$_}{'SUMMARYFILE'};
  671. }
  672. }
  673. # Otherwise, we were given a repository to query, figure out where we can
  674. # find the summary file for that repository.
  675. else {
  676. foreach (keys %repositories) {
  677. if ($location =~ /\Q$repositories{$_}{'LOCATION'}\E/i) {
  678. $locations{$repositories{$_}{'LOCATION'}} =
  679. $repositories{$_}{'SUMMARYFILE'};
  680. last;
  681. }
  682. }
  683. }
  684. # Check all of the summary file locations that we were able to find.
  685. foreach $location (keys %locations) {
  686. my $summaryfile = $locations{$location};
  687. unless ($summaryfile) {
  688. &Trace("RepositorySummary: No summary available from $location.")
  689. if $options{'TRACE'};
  690. $PPM::PPMERR = "No summary available from $location.\n";
  691. next;
  692. }
  693. my $data;
  694. if ($location =~ m@^...*://@i) {
  695. next unless ($data = read_href("request" => 'GET',
  696. "href" => "$location/$summaryfile"));
  697. } else {
  698. local $/;
  699. next if (!open (DATAFILE, "$location/$summaryfile"));
  700. $data = <DATAFILE>;
  701. close(DATAFILE);
  702. }
  703. $summary{$location} = parse_summary($data);
  704. }
  705. return %summary;
  706. }
  707. # Returns the same structure as RepositorySummary() above.
  708. sub ServerSearch
  709. {
  710. my %argv = @_;
  711. my $location = $argv{'location'};
  712. my $searchRE = $argv{'searchRE'};
  713. my $searchtag = $argv{'searchtag'};
  714. my $data;
  715. my %summary;
  716. return unless $location =~ m#^(http://.*)\?(urn:.*)#i;
  717. my ($proxy, $uri) = ($1, $2);
  718. my $client = SOAP::Lite -> uri($uri) -> proxy($proxy);
  719. eval { $data = $client ->
  720. search_ppds($Config{'archname'}, $searchRE, $searchtag) -> result; };
  721. if ($@) {
  722. &Trace("Error searching repository '$proxy': $@")
  723. if $options{'TRACE'};
  724. $PPM::PPMERR = "Error searching repository '$proxy': $@\n";
  725. return;
  726. }
  727. $summary{$location} = parse_summary($data);
  728. return %summary;
  729. }
  730. #
  731. # Internal subs
  732. #
  733. sub parse_summary
  734. {
  735. my $data = shift;
  736. my (%summary, @parsed);
  737. # take care of '&'
  738. $data =~ s/&(?!\w+;)/&amp;/go;
  739. my $parser = new XML::Parser( Style => 'Objects',
  740. Pkg => 'PPM::XML::RepositorySummary' );
  741. eval { @parsed = @{ $parser->parse( $data ) } };
  742. if ($@) {
  743. &Trace("parse_summary: content of summary file is not valid")
  744. if $options{'TRACE'};
  745. $PPM::PPMERR =
  746. "parse_summary: content of summary file is not valid: $!\n";
  747. return;
  748. }
  749. my $packages = ${$parsed[0]}{Kids};
  750. foreach my $package (@{$packages}) {
  751. my $elem_type = ref $package;
  752. $elem_type =~ s/.*:://;
  753. next if ($elem_type eq 'Characters');
  754. if ($elem_type eq 'SOFTPKG') {
  755. my %ret_hash;
  756. parsePPD(%{$package});
  757. %ret_hash = map { $_ => $current_package{$_} }
  758. qw(NAME TITLE AUTHOR VERSION ABSTRACT PERLCORE_VER);
  759. foreach my $dep (keys %{$current_package{'DEPEND'}}) {
  760. push @{$ret_hash{'DEPEND'}}, $dep;
  761. }
  762. $summary{$current_package{'NAME'}} = \%ret_hash;
  763. }
  764. }
  765. return \%summary;
  766. }
  767. sub save_options
  768. {
  769. read_config();
  770. my %PPMConfig;
  771. # Read in the existing PPM configuration file
  772. return unless (%PPMConfig = getPPDfile('package' => $PPM::PPMdat,
  773. 'parsertype' => 'PPM::XML::PPMConfig'));
  774. # Remove all of the declarations for REPOSITORY and PPMPRECIOUS;
  775. # we'll output these from the lists we've got in memory instead.
  776. foreach my $idx (0 .. @{$PPMConfig{Kids}}) {
  777. my $elem = $PPMConfig{Kids}[$idx];
  778. my $elem_type = ref $elem;
  779. if ($elem_type =~ /::REPOSITORY$|::PPMPRECIOUS$/o) {
  780. splice( @{$PPMConfig{Kids}}, $idx, 1 );
  781. redo; # Restart again so we don't miss any
  782. }
  783. }
  784. # Traverse the info we read in and replace the values in it with the new
  785. # config options that we've got.
  786. foreach my $elem (@{ $PPMConfig{Kids} }) {
  787. my $elem_type = ref $elem;
  788. $elem_type =~ s/.*:://;
  789. next if ($elem_type ne 'OPTIONS');
  790. %{$elem} = map { $_ => $options{$_} } keys %options;
  791. # This bit of ugliness is necessary for historical (VPM) reasons
  792. delete $elem->{FORCE_INSTALL};
  793. $elem->{FORCEINSTALL} = $options{'FORCE_INSTALL'};
  794. }
  795. # Find out where the package listings start and insert our PPMPRECIOUS and
  796. # updated list of REPOSITORYs.
  797. foreach my $idx (0 .. @{$PPMConfig{Kids}}) {
  798. my $elem = $PPMConfig{Kids}[$idx];
  799. my $elem_type = ref $elem;
  800. $elem_type =~ s/.*:://;
  801. next unless (($elem_type eq 'PACKAGE') or
  802. ($idx == $#{$PPMConfig{Kids}}));
  803. # Insert our PPMPRECIOUS
  804. my $chardata = new PPM::XML::PPMConfig::Characters;
  805. $chardata->{Text} = join( ';', @required_packages );
  806. my $precious = new PPM::XML::PPMConfig::PPMPRECIOUS;
  807. push( @{$precious->{Kids}}, $chardata );
  808. splice( @{$PPMConfig{Kids}}, $idx, 0, $precious );
  809. # Insert the list of repositories we've got
  810. my $rep_name;
  811. foreach $rep_name (keys %repositories) {
  812. my $repository = new PPM::XML::PPMConfig::REPOSITORY;
  813. %{$repository} =
  814. map { $_ => $repositories{$rep_name}{$_} }
  815. keys %{$repositories{$rep_name}};
  816. $repository->{'NAME'} = $rep_name;
  817. splice( @{$PPMConfig{Kids}}, $idx, 0, $repository );
  818. }
  819. last;
  820. }
  821. # Take the data structure we've got and bless it into a PPMCONFIG object so
  822. # that we can output it.
  823. my $cfg = bless \%PPMConfig, 'PPM::XML::PPMConfig::PPMCONFIG';
  824. # Open the output file and output the PPM config file
  825. unless (open( DAT, ">$PPM::PPMdat" )) {
  826. &Trace("open of $PPM::PPMdat failed: $!") if $options{'TRACE'};
  827. $PPM::PPMERR = "open of $PPM::PPMdat failed: $!\n";
  828. return 1;
  829. }
  830. my $oldout = select DAT;
  831. $cfg->output();
  832. select $oldout;
  833. close( DAT );
  834. &Trace("Wrote config file") if $options{'TRACE'} > 1;
  835. }
  836. # Gets a listing of all of the packages available in the repository. If an
  837. # argument of 'location' is provided in %argv, it is used as the repository to
  838. # query. This method returns to the caller a complete list of all of the
  839. # available packages at the repository in a list context, returning 'undef' if
  840. # any errors occurred.
  841. sub list_available
  842. {
  843. my %argv = @_;
  844. my $location = $argv{'location'};
  845. my @ppds;
  846. if ($location =~ /^file:\/\/.*\|/i) {
  847. # $location is a local directory, let's avoid LWP by changing
  848. # it to a pathname.
  849. $location =~ s@^file://@@i;
  850. $location =~ s@^localhost/@@i;
  851. $location =~ s@\|@:@;
  852. }
  853. # URL in UNC notation
  854. if ($location =~ /^file:\/\/\/\//i) {
  855. $location =~ s@^file://@@i;
  856. }
  857. # directory or UNC
  858. if (-d $location || $location =~ /^\\\\/ || $location =~ /^\/\//) {
  859. opendir(PPDDIR, $location) or return undef;
  860. my ($file);
  861. @ppds = grep { /\.ppd$/i && -f "$location/$_" } readdir(PPDDIR);
  862. foreach $file (@ppds) {
  863. $file =~ s/\.ppd//i;
  864. }
  865. }
  866. elsif ($location =~ m@^...*://@i) {
  867. if ($cached_ppd_list{$location}) {
  868. return @{$cached_ppd_list{$location}};
  869. }
  870. # If we're accessing a SOAP server, do things differently than we would
  871. # for FTP, HTTP, etc.
  872. if ($location =~ m#^(http://.*)\?(.*)#i) {
  873. my ($proxy, $uri) = ($1, $2);
  874. my $client = SOAP::Lite -> uri($uri) -> proxy($proxy);
  875. eval { @ppds = $client->packages()->paramsout };
  876. if ($@) {
  877. &Trace("Package list from '$proxy' failed: $@")
  878. if $options{'TRACE'};
  879. $PPM::PPMERR =
  880. "Package list from repository '$proxy' failed: $@\n";
  881. return;
  882. }
  883. }
  884. else {
  885. return unless (my $doc = read_href("href" => $location,
  886. "request" => 'GET'));
  887. if ($doc =~ /^<head><title>/) {
  888. # read an IIS format directory listing
  889. @ppds = grep { /\.ppd/i } split('<br>', $doc);
  890. foreach my $file (@ppds) {
  891. $file =~ s/\.ppd<.*$//is;
  892. $file =~ s@.*>@@is;
  893. }
  894. }
  895. elsif ($doc =~ /<BODY BGCOLOR=FFFFFF>\n\n<form name=VPMform/s) {
  896. # read output of default.prk over an HTTP connection
  897. @ppds = grep { /^<!--Key:.*-->$/ } split('\n', $doc);
  898. foreach my $file (@ppds) {
  899. if ($file =~ /^<!--Key:(.*)-->$/) {
  900. $file = $1;
  901. }
  902. }
  903. }
  904. else {
  905. # read an Apache format directory listing
  906. @ppds = grep { /\.ppd/i } split('\n', $doc);
  907. foreach my $file (@ppds) {
  908. $file =~ s/^.*>(.*?)\.ppd<.*$/$1/i;
  909. }
  910. }
  911. }
  912. # All done, take the list of PPDs that we've queried and cache it for
  913. # later re-use, then return it to the caller.
  914. @{$cached_ppd_list{$location}} = sort @ppds;
  915. return @{$cached_ppd_list{$location}};
  916. }
  917. return sort @ppds;
  918. }
  919. my ($response, $bytes_transferred);
  920. sub read_href
  921. {
  922. my %argv = @_;
  923. my $href = $argv{'href'};
  924. my $request = $argv{'request'};
  925. my $target = $argv{'target'};
  926. my $progress = $argv{'progress'}; # display status of binary transfers
  927. my ($proxy_user, $proxy_pass);
  928. # If this is a SOAP URL, handle it differently than FTP/HTTP/file.
  929. if ($href =~ m#^(http://.*)\?(.*)#i) {
  930. my ($proxy, $uri) = ($1, $2);
  931. my $fcn;
  932. if ($uri =~ m#(.*:/.*)/(.+?)$#) {
  933. ($uri, $fcn) = ($1, $2);
  934. }
  935. my $client = SOAP::Lite -> uri($uri) -> proxy($proxy);
  936. if ($fcn eq 'fetch_summary') {
  937. my $summary = eval { $client->fetch_summary()->result; };
  938. if ($@) {
  939. &Trace("Error getting summary from repository '$proxy': $@")
  940. if $options{'TRACE'};
  941. $PPM::PPMERR =
  942. "Error getting summary from repository '$proxy': $@\n";
  943. return;
  944. }
  945. return $summary;
  946. }
  947. $fcn =~ s/\.ppd$//i;
  948. my $ppd = eval { $client->fetch_ppd($fcn)->result };
  949. if ($@) {
  950. &Trace("Error fetching '$fcn' from repository '$proxy': $@")
  951. if $options{'TRACE'};
  952. $PPM::PPMERR =
  953. "Error fetching '$fcn' from repository '$proxy': $@\n";
  954. return;
  955. }
  956. return $ppd;
  957. # todo: write to disk file if $target
  958. }
  959. # Otherwise it's a standard URL, go ahead and request it using LWP.
  960. my $ua = new LWP::UserAgent;
  961. $ua->agent($ENV{HTTP_proxy_agent} || ("$0/0.1 " . $ua->agent));
  962. if (defined $ENV{HTTP_proxy}) {
  963. $proxy_user = $ENV{HTTP_proxy_user};
  964. $proxy_pass = $ENV{HTTP_proxy_pass};
  965. &Trace("read_href: calling env_proxy: $ENV{'HTTP_proxy'}")
  966. if $options{'TRACE'} > 1;
  967. $ua->env_proxy;
  968. }
  969. my $req = new HTTP::Request $request => $href;
  970. if (defined $proxy_user && defined $proxy_pass) {
  971. &Trace("read_href: calling proxy_authorization_basic($proxy_user, $proxy_pass)") if $options{'TRACE'} > 1;
  972. $req->proxy_authorization_basic("$proxy_user", "$proxy_pass");
  973. }
  974. # Do we need to do authorization?
  975. # This is a hack, but will have to do for now.
  976. foreach (keys %repositories) {
  977. if ($href =~ /^\Q$repositories{$_}{'LOCATION'}\E/i) {
  978. my $username = $repositories{$_}{'USERNAME'};
  979. my $password = $repositories{$_}{'PASSWORD'};
  980. if (defined $username && defined $password) {
  981. &Trace("read_href: calling proxy_authorization_basic($username, $password)") if $options{'TRACE'} > 1;
  982. $req->authorization_basic($username, $password);
  983. last;
  984. }
  985. }
  986. }
  987. ($response, $bytes_transferred) = (undef, 0);
  988. if ($progress) {
  989. # display the 'progress indicator'
  990. $ua->request($req, \&lwp_callback,
  991. ($options{'DOWNLOADSTATUS'} || 4096));
  992. print "\n" if ($PPM::PPMShell && $options{'DOWNLOADSTATUS'});
  993. }
  994. else {
  995. $response = $ua->request($req);
  996. }
  997. if ($response && $response->is_success) {
  998. if ($target) {
  999. unless (open(OUT, ">$target")) {
  1000. &Trace("read_href: Couldn't open $target for writing")
  1001. if $options{'TRACE'};
  1002. $PPM::PPMERR = "Couldn't open $target for writing\n";
  1003. return;
  1004. }
  1005. binmode(OUT);
  1006. print OUT $response->content;
  1007. close(OUT);
  1008. }
  1009. return $response->content;
  1010. }
  1011. if ($response) {
  1012. &Trace("read_href: Error reading $href: " . $response->code . " " .
  1013. $response->message) if $options{'TRACE'};
  1014. $PPM::PPMERR = "Error reading $href: " . $response->code . " " .
  1015. $response->message . "\n";
  1016. }
  1017. else {
  1018. &Trace("read_href: Error reading $href") if $options{'TRACE'};
  1019. $PPM::PPMERR = "Error reading $href\n";
  1020. }
  1021. return;
  1022. }
  1023. sub lwp_callback
  1024. {
  1025. my ($data, $res, $protocol) = @_;
  1026. $response = $res;
  1027. $response->add_content($data);
  1028. $bytes_transferred += length($data);
  1029. print "Bytes transferred: $bytes_transferred\r"
  1030. if ($PPM::PPMShell && $options{'DOWNLOADSTATUS'});
  1031. }
  1032. sub reread_config
  1033. {
  1034. %current_package = ();
  1035. %installed_packages = ();
  1036. $init = 0;
  1037. read_config();
  1038. }
  1039. # returns 0 on success, 1 and sets $PPMERR on error.
  1040. sub PPMdat_add_package
  1041. {
  1042. my ($location, $packlist, $inst_root) = @_;
  1043. my $package = $current_package{'NAME'};
  1044. my $time_str = localtime;
  1045. # If we already have this package installed, remove it from the PPM
  1046. # Configuration file so we can put the new one in.
  1047. if (defined $installed_packages{$package} ) {
  1048. # remove the existing entry for this package.
  1049. PPMdat_remove_package($package);
  1050. }
  1051. # Build the new SOFTPKG data structure for this package we're adding.
  1052. my $softpkg =
  1053. new PPM::XML::PPMConfig::SOFTPKG( NAME => $package,
  1054. VERSION => $current_package{VERSION}
  1055. );
  1056. if (defined $current_package{TITLE}) {
  1057. my $chardata = new PPM::XML::PPMConfig::Characters(
  1058. Text => $current_package{TITLE} );
  1059. my $newelem = new PPM::XML::PPMConfig::TITLE;
  1060. push( @{$newelem->{Kids}}, $chardata );
  1061. push( @{$softpkg->{Kids}}, $newelem );
  1062. }
  1063. if (defined $current_package{ABSTRACT}) {
  1064. my $chardata = new PPM::XML::PPMConfig::Characters(
  1065. Text => $current_package{ABSTRACT});
  1066. my $newelem = new PPM::XML::PPMConfig::ABSTRACT;
  1067. push( @{$newelem->{Kids}}, $chardata );
  1068. push( @{$softpkg->{Kids}}, $newelem );
  1069. }
  1070. if (defined $current_package{AUTHOR}) {
  1071. my $chardata = new PPM::XML::PPMConfig::Characters(
  1072. Text => $current_package{AUTHOR} );
  1073. my $newelem = new PPM::XML::PPMConfig::AUTHOR;
  1074. push( @{$newelem->{Kids}}, $chardata );
  1075. push( @{$softpkg->{Kids}}, $newelem );
  1076. }
  1077. if (defined $current_package{LICENSE}) {
  1078. my $chardata = new PPM::XML::PPMConfig::Characters(
  1079. Text => $current_package{LICENSE});
  1080. my $newelem = new PPM::XML::PPMConfig::LICENSE;
  1081. push( @{$newelem->{Kids}}, $chardata );
  1082. push( @{$softpkg->{Kids}}, $newelem );
  1083. }
  1084. my $impl = new PPM::XML::PPMConfig::IMPLEMENTATION;
  1085. push( @{$softpkg->{Kids}}, $impl );
  1086. if (defined $current_package{PERLCORE_VER}) {
  1087. my $newelem = new PPM::XML::PPMConfig::PERLCORE(
  1088. VERSION => $current_package{PERLCORE_VER} );
  1089. push( @{$impl->{Kids}}, $newelem );
  1090. }
  1091. foreach (keys %{$current_package{DEPEND}}) {
  1092. my $newelem = new PPM::XML::PPMConfig::DEPENDENCY(
  1093. NAME => $_, VERSION => $current_package{DEPEND}{$_} );
  1094. push( @{$impl->{Kids}}, $newelem );
  1095. }
  1096. my $codebase = new PPM::XML::PPMConfig::CODEBASE(
  1097. HREF => $current_package{CODEBASE} );
  1098. push( @{$impl->{Kids}}, $codebase );
  1099. my $inst = new PPM::XML::PPMConfig::INSTALL;
  1100. push( @{$impl->{Kids}}, $inst );
  1101. if (defined $current_package{INSTALL_EXEC})
  1102. { $inst->{EXEC} = $current_package{INSTALL_EXEC}; }
  1103. if (defined $current_package{INSTALL_HREF})
  1104. { $inst->{HREF} = $current_package{INSTALL_HREF}; }
  1105. if (defined $current_package{INSTALL_SCRIPT}) {
  1106. my $chardata = new PPM::XML::PPMConfig::Characters(
  1107. Text => $current_package{INSTALL_SCRIPT} );
  1108. push( @{$inst->{Kids}}, $chardata );
  1109. }
  1110. my $uninst = new PPM::XML::PPMConfig::UNINSTALL;
  1111. push( @{$impl->{Kids}}, $uninst );
  1112. if (defined $current_package{UNINSTALL_EXEC})
  1113. { $uninst->{EXEC} = $current_package{UNINSTALL_EXEC}; }
  1114. if (defined $current_package{UNINSTALL_HREF})
  1115. { $uninst->{HREF} = $current_package{UNINSTALL_HREF}; }
  1116. if (defined $current_package{UNINSTALL_SCRIPT}) {
  1117. my $chardata = new PPM::XML::PPMConfig::Characters(
  1118. Text => $current_package{UNINSTALL_SCRIPT} );
  1119. push( @{$uninst->{Kids}}, $chardata );
  1120. }
  1121. # Then, build the PACKAGE object and stick the SOFTPKG inside of it.
  1122. my $pkg = new PPM::XML::PPMConfig::PACKAGE( NAME => $package );
  1123. if ($location) {
  1124. my $chardata = new PPM::XML::PPMConfig::Characters( Text => $location );
  1125. my $newelem = new PPM::XML::PPMConfig::LOCATION;
  1126. push( @{$newelem->{Kids}}, $chardata );
  1127. push( @{$pkg->{Kids}}, $newelem );
  1128. }
  1129. if ($packlist) {
  1130. my $chardata = new PPM::XML::PPMConfig::Characters( Text => $packlist );
  1131. my $newelem = new PPM::XML::PPMConfig::INSTPACKLIST;
  1132. push( @{$newelem->{Kids}}, $chardata );
  1133. push( @{$pkg->{Kids}}, $newelem );
  1134. }
  1135. if ($inst_root) {
  1136. my $chardata = new PPM::XML::PPMConfig::Characters( Text => $inst_root );
  1137. my $newelem = new PPM::XML::PPMConfig::INSTROOT;
  1138. push( @{$newelem->{Kids}}, $chardata );
  1139. push( @{$pkg->{Kids}}, $newelem );
  1140. }
  1141. if ($time_str) {
  1142. my $chardata = new PPM::XML::PPMConfig::Characters( Text => $time_str);
  1143. my $newelem = new PPM::XML::PPMConfig::INSTDATE;
  1144. push( @{$newelem->{Kids}}, $chardata );
  1145. push( @{$pkg->{Kids}}, $newelem );
  1146. }
  1147. my $instppd = new PPM::XML::PPMConfig::INSTPPD;
  1148. push( @{$instppd->{Kids}}, $softpkg );
  1149. push( @{$pkg->{Kids}}, $instppd );
  1150. # Now that we've got the structure built, read in the existing PPM
  1151. # Configuration file, add this to it, and spit it back out.
  1152. my %PPMConfig;
  1153. return 1 unless (%PPMConfig = getPPDfile('package' => $PPM::PPMdat,
  1154. 'parsertype' => 'PPM::XML::PPMConfig'));
  1155. push( @{$PPMConfig{Kids}}, $pkg );
  1156. my $cfg = bless \%PPMConfig, 'PPM::XML::PPMConfig::PPMCONFIG';
  1157. unless (open( DAT, ">$PPM::PPMdat" )) {
  1158. &Trace("open of $PPM::PPMdat failed: $!") if $options{'TRACE'};
  1159. $PPM::PPMERR = "open of $PPM::PPMdat failed: $!\n";
  1160. return 1;
  1161. }
  1162. my $oldout = select DAT;
  1163. $cfg->output();
  1164. select $oldout;
  1165. close( DAT );
  1166. &Trace("PPMdat_add_package: wrote $PPM::PPMdat") if $options{'TRACE'} > 1;
  1167. return 0;
  1168. }
  1169. # returns 0 on success, 1 and sets $PPMERR on error.
  1170. sub PPMdat_remove_package
  1171. {
  1172. my $package = shift;
  1173. # Read in the existing PPM configuration file
  1174. my %PPMConfig;
  1175. return 1 unless (%PPMConfig = getPPDfile('package' => $PPM::PPMdat,
  1176. 'parsertype' => 'PPM::XML::PPMConfig'));
  1177. # Try to find the package that we're supposed to be removing, and yank it
  1178. # out of the list of installed packages.
  1179. foreach my $idx (0 .. @{$PPMConfig{Kids}}) {
  1180. my $elem = $PPMConfig{Kids}[$idx];
  1181. my $elem_type = ref $elem;
  1182. next if ($elem_type !~ /::PACKAGE$/o);
  1183. next if ($elem->{NAME} ne $package);
  1184. splice( @{$PPMConfig{Kids}}, $idx, 1 );
  1185. }
  1186. # Take the data structure we've got and bless it into a PPMCONFIG object so
  1187. # that we can output it again.
  1188. my $cfg = bless \%PPMConfig, 'PPM::XML::PPMConfig::PPMCONFIG';
  1189. # Now that we've removed the package, save the configuration file back out.
  1190. unless (open( DAT, ">$PPM::PPMdat" )) {
  1191. $PPM::PPMERR = "open of $PPM::PPMdat failed: $!\n";
  1192. return 1;
  1193. }
  1194. my $oldout = select DAT;
  1195. $cfg->output();
  1196. select $oldout;
  1197. close( DAT );
  1198. &Trace("PPMdat_remove_package: wrote $PPM::PPMdat")
  1199. if $options{'TRACE'} > 1;
  1200. return 0;
  1201. }
  1202. # Run $script using system(). If $scriptHREF is specified, its contents are
  1203. # used as the script. If $exec is specified, the script is saved to a
  1204. # temporary file and executed by $exec.
  1205. sub run_script
  1206. {
  1207. my %argv = @_;
  1208. my $script = $argv{'script'};
  1209. my $scriptHREF = $argv{'scriptHREF'};
  1210. my $exec = $argv{'exec'};
  1211. my $inst_root = $argv{'inst_root'};
  1212. my $inst_archlib = $argv{'inst_archlib'};
  1213. my (@commands, $tmpname);
  1214. if ($scriptHREF) {
  1215. if ($exec) {
  1216. # store in a temp file.
  1217. $tmpname = "$options{'BUILDDIR'}/PPM-" . time();
  1218. LWP::Simple::getstore($scriptHREF, $tmpname);
  1219. }
  1220. else {
  1221. my $doc = LWP::Simple::get $scriptHREF;
  1222. if (!defined $doc) {
  1223. &Trace("run_script: get $scriptHREF failed")
  1224. if $options{'TRACE'} > 1;
  1225. return 0;
  1226. }
  1227. @commands = split("\n", $doc);
  1228. }
  1229. }
  1230. else {
  1231. if (-f $script) {
  1232. $tmpname = $script;
  1233. }
  1234. else {
  1235. # change any escaped chars
  1236. $script =~ s/&lt;/</gi;
  1237. $script =~ s/&gt;/>/gi;
  1238. @commands = split(';;', $script);
  1239. if ($exec) {
  1240. # store in a temp file.
  1241. $tmpname = "$options{'BUILDDIR'}/PPM-" . time();
  1242. open(TMP, ">$tmpname");
  1243. foreach my $command (@commands) {
  1244. print TMP "$command\n";
  1245. }
  1246. close(TMP);
  1247. }
  1248. }
  1249. }
  1250. $ENV{'PPM_INSTROOT'} = $inst_root;
  1251. $ENV{'PPM_INSTARCHLIB'} = $inst_archlib;
  1252. if ($exec) {
  1253. $exec = $^X if ($exec =~ /^PPM_PERL$/i);
  1254. $exec = "start $exec" if $Config{'osname'} eq 'MSWin32';
  1255. system("$exec $tmpname");
  1256. }
  1257. else {
  1258. for my $command (@commands) {
  1259. system($command);
  1260. }
  1261. }
  1262. }
  1263. sub parsePPD
  1264. {
  1265. my %PPD = @_;
  1266. my $pkg;
  1267. %current_package = ();
  1268. # Get the package name and version from the attributes and stick it
  1269. # into the 'current package' global var
  1270. $current_package{NAME} = $PPD{NAME};
  1271. $current_package{VERSION} = $PPD{VERSION};
  1272. # Get all the information for this package and put it into the 'current
  1273. # package' global var.
  1274. my $got_implementation = 0;
  1275. my $elem;
  1276. foreach $elem (@{$PPD

Large files files are truncated, but you can click here to view the full file