Leaked source code of windows server 2003
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

553 lines
15 KiB

  1. @rem = '--*-Perl-*--
  2. @echo off
  3. if "%OS%" == "Windows_NT" goto WinNT
  4. "C:\Perl\bin\perl.exe" -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
  5. goto endofperl_ppminst
  6. :WinNT
  7. "C:\Perl\bin\perl.exe" -x -S %0 %*
  8. if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl_ppminst
  9. if %errorlevel% == 9009 echo You do not have Perl in your PATH.
  10. if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
  11. goto endofperl_ppminst
  12. @rem ';
  13. #!perl
  14. #line 15
  15. use strict;
  16. use FindBin;
  17. use lib "$FindBin::Bin/../lib";
  18. use Data::Dumper;
  19. use PPM::Config;
  20. my $VERSION = '3.00';
  21. my %INST;
  22. my %CONF;
  23. my %keys = (
  24. ARCHITECTURE => 0,
  25. CPU => 0,
  26. OSVALUE => 0,
  27. OSVERSION => 0,
  28. PERLCORE => 0,
  29. root => 1,
  30. tempdir => 1,
  31. TARGET_TYPE => 0,
  32. VERSION => 0,
  33. );
  34. my $ERR;
  35. #============================================================================
  36. # Register a dummy object which implements the required interface.
  37. #============================================================================
  38. my $i = bless { }, "Implementation";
  39. PPM::InstallerClient::init($ENV{PPM_PORT}, $i);
  40. #============================================================================
  41. # Command Implementors
  42. #============================================================================
  43. package Implementation;
  44. @Implementation::ISA = qw(PPM::InstallerClient);
  45. use Config;
  46. use Fcntl qw(LOCK_SH LOCK_UN LOCK_EX);
  47. use PPM::InstallerClient;
  48. use PPM::PPD;
  49. use PPM::Search;
  50. use Data::Dumper;
  51. # There's a bug in ExtUtils::Install in perl 5.6.1.
  52. # Also exists in ActivePerl 522 (line 168)
  53. BEGIN {
  54. local $^W;
  55. require ExtUtils::Install;
  56. }
  57. # Query installed packages: returns a list of records about the results.
  58. sub query {
  59. my $inst = shift;
  60. my $query = shift;
  61. my $case = shift;
  62. load_pkgs();
  63. my @ppds = map { $_->{ppd} } values %INST;
  64. my @matches = PPM::PPD::Search->new($query, $case)->search(@ppds);
  65. return map { $_->ppd } @matches;
  66. }
  67. sub properties {
  68. my $inst = shift;
  69. my $pkg = shift;
  70. if (pkg_installed($pkg) && load_pkg($pkg)) {
  71. return ($INST{$pkg}{ppd}->ppd,
  72. $INST{$pkg}{pkg}{INSTDATE},
  73. $INST{$pkg}{pkg}{LOCATION});
  74. }
  75. $ERR = "'$pkg' is not installed";
  76. return ();
  77. }
  78. sub dependents {
  79. my $inst = shift;
  80. my $pkg = shift;
  81. if (pkg_installed($pkg) && load_pkg($pkg)) {
  82. return @{ $INST{$pkg}{pkg}{dependents} || [] };
  83. }
  84. undef;
  85. }
  86. sub remove {
  87. my $inst = shift;
  88. my $pkg = shift;
  89. if (pkg_installed($pkg) && load_pkg($pkg)) {
  90. my $packlist = $INST{$pkg}{pkg}{INSTPACKLIST};
  91. (my $altpacklist = $packlist) =~ s<\Q$CONF{ARCHITECTURE}\E[\\/]><>i;
  92. if (-f $packlist) {
  93. eval {
  94. ExtUtils::Install::uninstall($packlist, 1, 0);
  95. };
  96. }
  97. elsif (-f $altpacklist) {
  98. eval {
  99. ExtUtils::Install::uninstall($altpacklist, 1, 0);
  100. };
  101. }
  102. $ERR = "$@" and return 0 if $@;
  103. # Update html table of contents, if ActivePerl::DocTools is installed:
  104. if (eval { require ActivePerl::DocTools; 1 }) {
  105. ActivePerl::DocTools::WriteTOC();
  106. }
  107. # Remove the package and references to it:
  108. my $ppd_ref = $INST{$pkg}{ppd};
  109. for my $impl ($ppd_ref->implementations) {
  110. my $match = 1;
  111. for my $field (keys %$impl) {
  112. next if ref($field);
  113. my $value = $inst->config_get($field);
  114. next unless defined $value;
  115. $match &&= ($value eq $impl->{$field});
  116. }
  117. if ($match == 1) {
  118. del_dependent($_->name, $ppd_ref->name)
  119. for $impl->prereqs;
  120. last;
  121. }
  122. }
  123. purge_pkg($pkg);
  124. }
  125. else {
  126. $ERR = "package '$pkg' not installed.";
  127. return 0;
  128. }
  129. return 1;
  130. }
  131. sub precious {
  132. return @{$CONF{precious}};
  133. }
  134. sub bundled {
  135. return @{$CONF{bundled}};
  136. }
  137. sub upgrade {
  138. my ($inst, $pkg, $ppmpath, $ppd, $repos) = @_;
  139. remove($inst, $pkg);
  140. install($inst, $pkg, $ppmpath, $ppd, $repos);
  141. }
  142. sub install {
  143. my ($inst, $pkg, $ppmpath, $ppd, $repos) = @_;
  144. use Cwd qw(getcwd);
  145. my $cwd = getcwd();
  146. # Install:
  147. # 1. chdir to temp directory
  148. chdir $ppmpath or do {
  149. $ERR = "can't chdir to $ppmpath: $!";
  150. return 0;
  151. };
  152. chdir $pkg; # this is expected to fail!
  153. reloc_perl('.') if $Config{osname} ne 'MSWin32';
  154. # 2. use ExtUtils::MakeMaker to install the blib
  155. my $inst_archlib = $Config{installsitearch};
  156. my $inst_root = $Config{prefix};
  157. my $packlist = MM->catfile("$inst_archlib/auto",
  158. split(/-/, $pkg), ".packlist");
  159. # Copied from ExtUtils::Install
  160. my $INST_LIB = MM->catdir(MM->curdir, "blib", "lib");
  161. my $INST_ARCHLIB = MM->catdir(MM->curdir, "blib", "arch");
  162. my $INST_BIN = MM->catdir(MM->curdir, "blib", "bin");
  163. my $INST_SCRIPT = MM->catdir(MM->curdir, "blib", "script");
  164. my $INST_MAN1DIR = MM->catdir(MM->curdir, "blib", "man1");
  165. my $INST_MAN3DIR = MM->catdir(MM->curdir, "blib", "man3");
  166. my $INST_HTMLDIR = MM->catdir(MM->curdir, "blib", "html");
  167. my $INST_HTMLHELPDIR = MM->catdir(MM->curdir, "blib", "htmlhelp");
  168. my $inst_script = $Config{installscript};
  169. my $inst_man1dir = $Config{installman1dir};
  170. my $inst_man3dir = $Config{installman3dir};
  171. my $inst_bin = $Config{installbin};
  172. my $inst_htmldir = $Config{installhtmldir};
  173. my $inst_htmlhelpdir = $Config{installhtmlhelpdir};
  174. my $inst_lib = $Config{installsitelib};
  175. # For some reason, some boxes don't have installhtml* in Config.pm:
  176. $inst_htmldir ||= "$inst_bin/../html";
  177. $inst_htmlhelpdir ||= "$inst_bin/../html";
  178. if ($CONF{root} && $CONF{root} !~ /^\Q$inst_root\E$/i) {
  179. my $root = $CONF{root};
  180. $packlist =~ s/\Q$inst_root/$root\E/i;
  181. $inst_lib =~ s/\Q$inst_root/$root\E/i;
  182. $inst_archlib =~ s/\Q$inst_root/$root\E/i;
  183. $inst_bin =~ s/\Q$inst_root/$root\E/i;
  184. $inst_script =~ s/\Q$inst_root/$root\E/i;
  185. $inst_man1dir =~ s/\Q$inst_root/$root\E/i;
  186. $inst_man3dir =~ s/\Q$inst_root/$root\E/i;
  187. $inst_htmldir =~ s/\Q$inst_root/$root\E/i;
  188. $inst_htmlhelpdir =~ s/\Q$inst_root/$root\E/i;
  189. $inst_root = $root;
  190. }
  191. while (1) {
  192. eval {
  193. ExtUtils::Install::install({
  194. "read" => $packlist, "write" => $packlist,
  195. $INST_LIB => $inst_lib, $INST_ARCHLIB => $inst_archlib,
  196. $INST_BIN => $inst_bin, $INST_SCRIPT => $inst_script,
  197. $INST_MAN1DIR => $inst_man1dir, $INST_MAN3DIR => $inst_man3dir,
  198. $INST_HTMLDIR => $inst_htmldir,
  199. $INST_HTMLHELPDIR => $inst_htmlhelpdir},0,0,0);
  200. };
  201. # install might have croaked in another directory
  202. chdir $cwd;
  203. # Can't remove some DLLs, but we can rename them and try again.
  204. if ($@ && $@ =~ /Cannot forceunlink (\S+)/) {
  205. my $oldname = $1;
  206. $oldname =~ s/:$//;
  207. my $newname = $oldname . "." . time();
  208. unless (rename($oldname, $newname)) {
  209. $ERR = "renaming $oldname to $newname: $!";
  210. return 0;
  211. }
  212. }
  213. # Some other error
  214. elsif($@) {
  215. $ERR = "$@";
  216. return 0;
  217. }
  218. else { last; }
  219. }
  220. # Update html table of contents, if ActivePerl::DocTools is installed:
  221. if (eval { require ActivePerl::DocTools; 1 }) {
  222. ActivePerl::DocTools::WriteTOC();
  223. }
  224. # XXX: Run the install script if it exists
  225. # Add the package to the list of installed packages
  226. my $ppd_ref = PPM::PPD->new($ppd);
  227. $INST{$pkg} = {
  228. pkg => {
  229. INSTDATE => scalar localtime,
  230. LOCATION => $repos,
  231. INSTROOT => $CONF{root},
  232. INSTPACKLIST => $packlist,
  233. },
  234. ppd => $ppd_ref,
  235. };
  236. save_pkg($pkg);
  237. # "Register" the package as dependent on each prerequisite:
  238. # Note: because the PPM::PPD package's find_impl() is designed to use a
  239. # PPM::Installer() object, we can't use it. Instead, we have to do the
  240. # work ourselves, here:
  241. for my $impl ($ppd_ref->implementations) {
  242. my $match = 1;
  243. for my $field (keys %$impl) {
  244. next if ref($field);
  245. my $value = $inst->config_get($field);
  246. next unless defined $value;
  247. $match &&= ($value eq $impl->{$field});
  248. }
  249. if ($match == 1) {
  250. add_dependent($_->name, $pkg)
  251. for $impl->prereqs;
  252. last;
  253. }
  254. }
  255. return 1;
  256. }
  257. sub config_keys {
  258. map { [$_, $keys{$_}] } keys %keys;
  259. }
  260. sub _str {
  261. my $a = shift;
  262. return '' unless defined $a;
  263. $a;
  264. }
  265. sub config_info {
  266. map { [$_, _str($CONF{$_})] } keys %keys;
  267. }
  268. sub config_set {
  269. my $inst = shift;
  270. my ($key, $val) = @_;
  271. unless (defined $keys{$key}) {
  272. $ERR = "unknown config key '$key'";
  273. return 0;
  274. }
  275. $CONF{$key} = $val;
  276. return 1;
  277. }
  278. sub config_get {
  279. my $inst = shift;
  280. my $key = shift;
  281. unless (defined $key and exists $keys{$key}) {
  282. $key = '' unless defined $key;
  283. $ERR = "unknown config key '$key'";
  284. return undef;
  285. }
  286. _str($CONF{$key});
  287. }
  288. sub error_str {
  289. defined $ERR ? $ERR : 'No error';
  290. }
  291. #----------------------------------------------------------------------------
  292. # Utilities
  293. #----------------------------------------------------------------------------
  294. # This can deal with files as well as directories
  295. sub abspath {
  296. use Cwd qw(abs_path);
  297. my ($path, $file) = shift;
  298. if (-f $path) {
  299. my @p = split '/', $path;
  300. $path = join '/', @p[0..$#p-1]; # can't use -2 in a range
  301. $file = $p[-1];
  302. }
  303. $path = abs_path($path);
  304. return ($path, $file, defined $file ? join '/', $path, $file : ())
  305. if wantarray;
  306. return defined $file ? join '/', $path, $file : $path;
  307. }
  308. #============================================================================
  309. # Relocate Perl (stolen from PPM::RelocPerl)
  310. #============================================================================
  311. my $frompath_default;
  312. BEGIN {
  313. # We have to build up this variable, otherwise
  314. # PPM will mash it when it upgrades itself.
  315. $frompath_default =
  316. ('/tmp' .
  317. '/.ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZpErLZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZperl'
  318. );
  319. }
  320. my ($topath, $frompath);
  321. sub wanted {
  322. if (-l) {
  323. return; # do nothing for symlinks
  324. }
  325. elsif (-B) {
  326. check_for_frompath($_, 1); # binary file edit
  327. }
  328. elsif (-e && -s && -f) {
  329. check_for_frompath($_, 0); # text file edit
  330. }
  331. }
  332. sub check_for_frompath {
  333. my ($file, $binmode) = @_;
  334. local(*F, $_);
  335. open(F, "<$file") or die "Can't open `$file': $!";
  336. binmode F if $binmode;
  337. while (<F>) {
  338. if (/\Q$frompath\E/o) {
  339. close F;
  340. edit_it($file, $binmode);
  341. last;
  342. }
  343. }
  344. # implicit close of F;
  345. }
  346. sub edit_it
  347. {
  348. my ($file, $binmode) = @_;
  349. my $nullpad = length($frompath) - length($topath);
  350. $nullpad = "\0" x $nullpad;
  351. local $/;
  352. # Force the file to be writable
  353. my $mode = (stat($file))[2] & 07777;
  354. chmod $mode | 0222, $file;
  355. open(F, "+<$file") or die "Couldn't open $file: $!";
  356. binmode(F) if $binmode;
  357. my $dat = <F>;
  358. if ($binmode) {
  359. $dat =~ s|\Q$frompath\E(.*?)\0|$topath$1$nullpad\0|gs;
  360. } else {
  361. $dat =~ s|\Q$frompath\E|$topath|gs;
  362. }
  363. seek(F, 0, 0) or die "Couldn't seek on $file: $!";
  364. truncate(F, 0);
  365. print F $dat;
  366. close(F);
  367. # Restore the permissions
  368. chmod $mode, $file;
  369. }
  370. use File::Find;
  371. sub reloc_perl
  372. {
  373. my ($dir, $opt_topath, $opt_frompath) = @_;
  374. $topath = defined $opt_topath ? $opt_topath : $Config{'prefix'};
  375. $frompath = defined $opt_frompath ? $opt_frompath : $frompath_default;
  376. find(\&wanted, $dir);
  377. }
  378. #============================================================================
  379. # Settings and packages
  380. #============================================================================
  381. my ($conf_dir, $conf, $conf_obj);
  382. BEGIN {
  383. # By putting an invalid package character in the directory, we're making
  384. # sure no real package could overwrite our settings, and vice versa.
  385. $conf_dir = join '/', $Config{sitelib}, 'ppm-conf';
  386. $conf = join '/', $conf_dir, 'ppm.cfg';
  387. }
  388. # Loads the configuration file and populates %CONF
  389. sub load_conf {
  390. $conf_obj = PPM::Config->new($conf);
  391. %CONF = $conf_obj->config;
  392. # Special values; set them here
  393. $CONF{ARCHITECTURE} = $Config{archname};
  394. $CONF{PERLCORE} = $Config{version};
  395. $CONF{TARGET_TYPE} = "perl";
  396. $CONF{VERSION} = '3.00';
  397. }
  398. # Saves %CONF to the configuration file
  399. sub save_conf {
  400. $conf_obj->merge(\%CONF);
  401. $conf_obj->save;
  402. }
  403. # Loads the given package into $INST{$pkg}. Returns true if the package could
  404. # be loaded, false otherwise.
  405. sub load_pkg {
  406. my $pkg = shift;
  407. return 1 if exists $INST{$pkg};
  408. return 0 unless -f "$conf_dir/$pkg.ppd";
  409. return 0 unless -f "$conf_dir/$pkg.pkg";
  410. my $ppdref = PPM::PPD->new("$conf_dir/$pkg.ppd");
  411. my $pkgfile = "$conf_dir/$pkg.pkg";
  412. my $pkgref = PPM::Config->new($pkgfile);
  413. $INST{$pkg}{ppd} = $ppdref;
  414. $INST{$pkg}{pkg} = $pkgref->config;
  415. return 1;
  416. }
  417. # Saves the given package from $INST{$pkg}.
  418. sub save_pkg {
  419. my $pkg = shift;
  420. return 0 unless exists $INST{$pkg};
  421. # The PPD file:
  422. my $ppdfile = "$conf_dir/$pkg.ppd";
  423. if (-f $ppdfile) {
  424. unlink $ppdfile or die "$0: can't delete $ppdfile: $!";
  425. }
  426. open PPD, "> $ppdfile" or die "$0: can't write $ppdfile: $!";
  427. print PPD $INST{$pkg}{ppd}->ppd;
  428. close PPD or die "$0: can't close $ppdfile: $!";
  429. # the PKG file:
  430. my $c = PPM::Config->new;
  431. $c->load($INST{$pkg}{pkg});
  432. $c->save("$conf_dir/$pkg.pkg");
  433. return 1;
  434. }
  435. sub add_dependent {
  436. my $package = shift;
  437. my $dependent = shift;
  438. return 0 unless load_pkg($package);
  439. push @{$INST{$package}{pkg}{dependents}}, $dependent;
  440. save_pkg($package);
  441. }
  442. sub del_dependent {
  443. my $package = shift;
  444. my $dependent = shift;
  445. return 0 unless load_pkg($package);
  446. @{$INST{$package}{pkg}{dependents}}
  447. = grep { $_ ne $dependent }
  448. @{$INST{$package}{pkg}{dependents}};
  449. save_pkg($package);
  450. }
  451. sub purge_pkg {
  452. my $pkg = shift;
  453. # The PPD file:
  454. my $ppdfile = "$conf_dir/$pkg.ppd";
  455. if (-f $ppdfile) {
  456. unlink $ppdfile or die "$0: can't delete $ppdfile: $!";
  457. }
  458. # The %INST entry:
  459. delete $INST{$pkg};
  460. # The PKG file:
  461. my $pkgfile = "$conf_dir/$pkg.pkg";
  462. if (-f $pkgfile) {
  463. unlink $pkgfile or die "$0: can't delete $pkgfile: $!";
  464. }
  465. return 1;
  466. }
  467. # Load all packages: only needed when doing an advanced query
  468. sub load_pkgs {
  469. my @pkgs = map { s/\.ppd$//; s!.*/([^/]+)$!$1!g; $_ } #!
  470. glob "$conf_dir/*.ppd";
  471. load_pkg($_) for @pkgs;
  472. }
  473. sub pkg_installed {
  474. my $pkg = shift;
  475. return -f "$conf_dir/$pkg.ppd" && -f "$conf_dir/$pkg.pkg";
  476. }
  477. BEGIN {
  478. load_conf();
  479. }
  480. END {
  481. save_conf();
  482. }
  483. __END__
  484. :endofperl_ppminst