home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _9a766ed3737acef9c1ad9581144db8bc < prev    next >
Encoding:
Text File  |  2004-06-01  |  12.1 KB  |  459 lines
  1. package PPM::Config;
  2.  
  3. use strict;
  4. use Data::Dumper;
  5. use File::Path;
  6. require PPM::YAML;
  7.  
  8. $PPM::Config::VERSION = '3.00';
  9.  
  10. sub new {
  11.     my $class = shift;
  12.     my $self = bless { }, ref($class) || $class;
  13.     my $file = shift;
  14.     $self->{DATA} = {};
  15.     if (defined $file) {
  16.     $self->loadfile($file, 'load');
  17.     $self->setfile($file);
  18.     $self->setsave;
  19.     }
  20.     return $self;
  21. }
  22.  
  23. sub config {
  24.     my $o = shift;
  25.     return wantarray ? %{$o->{DATA}} : $o->{DATA};
  26. }
  27.  
  28. sub loadfile {
  29.     my $o = shift;
  30.     my $file = shift;
  31.     my $action = shift;
  32.     print "DEBUG: Loading file: $file.\n" if $ENV{PPM3_CONFIG_DEBUG};
  33.     open(FILE, "< $file")        || die "can't read $file: $!";
  34.     my $str = do { local $/; <FILE> };
  35.     my $dat = eval { PPM::YAML::deserialize($str) } || {};
  36.     close(FILE)                || die "can't close $file: $!";
  37.     $o->load($dat, $action);
  38.     $o;
  39. }
  40.  
  41. sub load {
  42.     my $o = shift;
  43.     my $dat = shift;
  44.     my $action = shift || 'load';
  45.     if ($action eq 'load' or not exists $o->{DATA}) {
  46.     $o->{DATA} = $dat;
  47.     }
  48.     else {
  49.     $o->merge($dat);
  50.     }
  51.     $o;
  52. }
  53.  
  54. sub file { $_[0]->{file} }
  55.  
  56. sub setfile {
  57.     my $o = shift;
  58.     my $file = shift;
  59.     $o->{file} = $file;
  60.     $o;
  61. }
  62.  
  63. sub setsave {
  64.     my $o = shift;
  65.     $o->{autosave} = 1;
  66.     $o;
  67. }
  68.  
  69. sub save {
  70.     my $o = shift;
  71.     my $file = shift || $o->{file};
  72.     my $mode = (stat($file))[2] & 07777;
  73.     $mode |= 0222;      # turn on write permissions (if not already)
  74.     chmod $mode, $file; # ignore failures
  75.     open(FILE, "> $file") or do {
  76.     print STDERR <<END;
  77. Warning: save $file: $!.
  78.     => Configuration not saved.
  79. END
  80.     return;
  81.     };
  82.     my $str = PPM::YAML::serialize($o->{DATA});
  83.     print FILE $str;
  84.     close(FILE)                || die "can't close $file: $!";
  85.     $o;
  86. }
  87.  
  88. sub merge {
  89.     my $o = shift;
  90.     my $dat = shift;
  91.     _merge(\$o->{DATA}, \$dat)
  92.       if (defined $dat);
  93.     $o;
  94. }
  95.  
  96. sub DESTROY {
  97.     my $o = shift;
  98.     $o->save if $o->{autosave};
  99. }
  100.  
  101. sub _merge {
  102.     my ($old_ref, $new_ref) = @_;
  103.  
  104.     return unless defined $old_ref and defined $new_ref;
  105.  
  106.     my $r_old = ref($old_ref);
  107.     my $r_new = ref($new_ref);
  108.  
  109.     return unless $r_old eq $r_new;
  110.     
  111.     if ($r_old eq 'SCALAR') {
  112.     $$old_ref = $$new_ref;
  113.     }
  114.     elsif ($r_old eq 'REF') {
  115.     my $old = $$old_ref;
  116.     my $new = $$new_ref;
  117.     $r_old = ref($old);
  118.     $r_new = ref($new);
  119.  
  120.     return unless $r_old eq $r_new;
  121.  
  122.     if (ref($old) eq 'HASH') {
  123.         for my $key (keys %$new) {
  124.         if (exists $old->{$key} and
  125.             defined $old->{$key} and
  126.             defined $new->{$key}) {
  127.             _merge(\$old->{$key}, \$new->{$key});
  128.         }
  129.         else {
  130.             $old->{$key} = $new->{$key};
  131.         }
  132.         }
  133.     }
  134.     elsif (ref($old) eq 'ARRAY') {
  135.         for my $item (@$new) {
  136.         if (ref($item) eq '' and not grep { $item eq $_ } @$old) {
  137.             push @$old, $item;
  138.         }
  139.         elsif(ref($item)) {
  140.             push @$old, $item;
  141.         }
  142.         }
  143.     }
  144.     }
  145. }
  146.  
  147. #=============================================================================
  148. # get_conf_dirs(): return a list of directories to search for config files.
  149. #=============================================================================
  150. use constant DELIM    => $^O eq 'MSWin32' ? ';' : ':';
  151. use constant PATHSEP    => $^O eq 'MSWin32' ? '\\' : '/';
  152. use constant KEYDIR    => 'ActiveState';
  153. use constant KEYFILE    => 'ActiveState.lic';
  154. use constant CONFDIR    => 'PPM';
  155. use constant CONFIG_SUFFIX => '.cfg';
  156. use constant UNIX_SHARED_ROOT => '/usr/local/etc';
  157.  
  158. sub mymkpath {
  159.     my $path = shift;
  160.     unless (-d $path) {
  161.     mkpath($path);
  162.     die "Couldn't create directory $path: $!"
  163.       unless -d $path;
  164.     }
  165.     $path;
  166. }
  167.  
  168. sub get_license_file {
  169.     my $license_dir = licGetHomeDir();
  170.     my $lic_file = join PATHSEP, $license_dir, KEYFILE;
  171.     return $lic_file;
  172. }
  173.  
  174. BEGIN {
  175.     if ($ENV{PPM3_CONFIG_DEBUG}) {
  176.     my $shared = $ENV{PPM3_SHARED} ? '' : 'not ';
  177.     my $user   = $ENV{PPM3_USER}   ? '' : 'not ';
  178.     print <<END;
  179. DEBUG: Will ${shared}stat shared configuration files...
  180. DEBUG: Will ${user}stat user's configuration files...
  181. END
  182.     }
  183. }
  184.  
  185. sub load_config_file {
  186.     my $orig = shift;
  187.     my $mode = shift || 'rw'; # 'ro' for read-only.
  188.  
  189.     my $name = $orig . CONFIG_SUFFIX;
  190.     my $conf = PPM::Config->new;
  191.  
  192.     # Load all config files in the "configuration path"
  193.     my $treedir = eval { get_tree_conf_dir()   };
  194.     my $userdir = eval { get_user_conf_dir()   };
  195.     my $shrddir = eval { get_shared_conf_dir() };
  196.     unless (grep { defined $_ } ($userdir, $shrddir, $treedir)) {
  197.     print <<END;
  198.  
  199.     *** FATAL ERROR *** 
  200.     
  201.     Couldn't find the PPM configuration directories in either your home
  202.     directory or the shared directory. That probably means neither of the
  203.     environment variables PPM3_SHARED and PPM3_USER were set by the wrapper
  204.     program "ppm3".
  205.  
  206.     Set the environment variable PPM3_CONFIG_DEBUG to 1, then rerun PPM
  207.     to get more diagnostics about where it loaded its initial
  208.     configuration.
  209.  
  210. END
  211.     exit(1);
  212.     }
  213.     my ($treefile, $userfile, $shrdfile);
  214.     $treefile = defined $treedir ? join PATHSEP, $treedir, $name : '';
  215.     $userfile = defined $userdir ? join PATHSEP, $userdir, $name : '';
  216.     $shrdfile = defined $shrddir ? join PATHSEP, $shrddir, $name : '';
  217.     print "DEBUG: treefile='$treefile'\n" if $ENV{PPM3_CONFIG_DEBUG};
  218.     print "DEBUG: userfile='$userfile'\n" if $ENV{PPM3_CONFIG_DEBUG};
  219.     print "DEBUG: shrdfile='$shrdfile'\n" if $ENV{PPM3_CONFIG_DEBUG};
  220.  
  221.     # Pick the least public place to save changes.
  222.     my $saveto = $treefile ? $treefile :
  223.          $userfile ? $userfile : $shrdfile;
  224.     $conf->setfile($saveto);
  225.     $conf->setsave unless $mode eq 'ro';
  226.  
  227.     # Load the "most private" file.
  228.     return $conf->loadfile($treefile) if -f $treefile && -s _;
  229.     return $conf->loadfile($userfile) if -f $userfile && -s _;
  230.     return $conf->loadfile($shrdfile) if -f $shrdfile && -s _;
  231.  
  232.     # Neither the shared nor the user's file exists. Let's attempt to
  233.     # create a stub copy of the file, initialised to reasonable defaults.
  234.     print "DEBUG: Writing a stub config file for '$name'.\n"
  235.     if $ENV{PPM3_CONFIG_DEBUG};
  236.     eval {
  237.     # Create config dir _even_ if we're going to load the file ro.
  238.     my $stubfile = $conf->file;
  239.     local *FILE;
  240.     open (FILE, "> $stubfile") or die $!;    # caught by the eval
  241.     print FILE config_file_stub($orig);    # write stub config
  242.     close FILE or die $!;
  243.     $conf->loadfile($stubfile);
  244.     };
  245.     if ($@) {
  246.     die "Fatal error: couldn't find or create config file $name: $@";
  247.     }
  248.  
  249.     return $conf;
  250. }
  251.  
  252. # Returns the "tree" configuration directory. This is the directory used by
  253. # 'ppminst'.
  254. sub tree_conf_dir {
  255.     my $d = $ENV{PPM3_PERL_SITELIB}
  256.             || do { require Config; $Config::Config{sitelibexp} };
  257.     return "$d/ppm-conf";
  258. }
  259.  
  260. sub get_tree_conf_dir {
  261.     return mymkpath(tree_conf_dir());
  262. }
  263.  
  264. # Returns the user's configuration directory. Note: throws an exception if the
  265. # directory doesn't exist and cannot be created.
  266. sub get_user_conf_dir {
  267.     return undef unless $ENV{PPM3_USER};
  268.     return mymkpath(join PATHSEP, licGetHomeDir(), CONFDIR);
  269. }
  270.  
  271. # Returns the shared configuration directory. Note: throws no exception, but
  272. # the directory is not guaranteed to exist. Install scripts and such should be
  273. # sure to create this directory themselves.
  274. sub get_shared_conf_dir {
  275.     return undef unless $ENV{PPM3_SHARED};
  276.     return join PATHSEP, UNIX_SHARED_ROOT, KEYDIR, CONFDIR
  277.       if $^O ne 'MSWin32';
  278.  
  279.     my ($R,%R);
  280.     require Win32::TieRegistry;
  281.     Win32::TieRegistry->import(TiedHash => \%R);
  282.     bless do { $R = \%R }, "Win32::TieRegistry";
  283.     $R->Delimiter('/');
  284.     my $wkey = $R->{"HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows/"};
  285.     my $xkey = $wkey->{"CurrentVersion/Explorer/Shell Folders/"};
  286.     my $shared_root = $xkey->{"/Common AppData"};
  287.     return join PATHSEP, $shared_root, KEYDIR, CONFDIR;
  288. }
  289.  
  290. sub get_conf_dirs {
  291.     my @path;
  292.     push @path, get_shared_conf_dir(), get_user_conf_dir();
  293.     @path
  294. }
  295.  
  296. #=============================================================================
  297. # licGetHomeDir(): copied and converted from the Licence_V8 code:
  298. #=============================================================================
  299. sub licGetHomeDir {
  300.     my $dir;
  301.     my ($env1, $env2);
  302.  
  303.     if ($^O eq 'MSWin32') {
  304.     require Win32;
  305.     if (defined &Win32::GetFolderPath) {
  306.         $env1 = Win32::GetFolderPath(Win32::CSIDL_APPDATA());
  307.     }
  308.     $env1 = $ENV{APPDATA} unless defined $env1;
  309.     }
  310.  
  311.     unless ($env1) {
  312.     $env1 = $ENV{HOME};
  313.     }
  314.  
  315.     # On Linux & Solaris:
  316.     if ($^O ne 'MSWin32') {
  317.     unless ($env1) {
  318.         $env1 = (getpwuid $<)[7]; # Try to get $ENV{HOME} the hard way
  319.     }
  320.     $dir = sprintf("%s/.%s", $env1, KEYDIR);
  321.     }
  322.  
  323.     # On Windows:
  324.     else {
  325.     unless ($env1) {
  326.         $env1 = $ENV{USERPROFILE};
  327.     }
  328.     unless ($env1) {
  329.         $env1 = $ENV{HOMEDRIVE};
  330.         $env2 = $ENV{HOMEPATH};
  331.     }
  332.     unless ($env1) {
  333.         $env1 = $ENV{windir};
  334.     }
  335.     unless ($env1) {
  336.         die ("Couldn't find HOME / USERPROFILE / HOMEDRIVE&HOMEPATH / windir");
  337.     }
  338.     $env2 ||= "";
  339.     $dir = $env1 . $env2;
  340.     $dir =~ s|/|\\|g;
  341.  
  342.     # Win32 _stat() doesn't like trailing backslashes, except for x:\
  343.     while (length($dir) > 3 && substr($dir, -1) eq '\\') {
  344.         chop($dir);
  345.     }
  346.  
  347.     die ("Not a directory: $dir") unless -d $dir;
  348.  
  349.     $dir .= PATHSEP;
  350.     $dir .= KEYDIR;
  351.     }
  352.  
  353.     # Create it if it doesn't exist yet
  354.     return mymkpath($dir);
  355. }
  356.  
  357. sub repository {
  358.     my $rep  = shift;
  359.     my $ver = $^V ? sprintf("%vd", substr($^V,0,2)) : $];
  360.  
  361.     my $ppm3 = "http://ppm.ActiveState.com/PPM/ppmserver%s.plex?urn:/PPM/Server/SQL";
  362.     my $ppm2 = "http://ppm.ActiveState.com/cgibin/PPM/ppmserver%s.pl?urn:/PPMServer";
  363.     my $www  = "http://ppm.ActiveState.com/PPMPackages/%s";
  364.  
  365.     my $verplat1 = "";
  366.     my $verplat2 = $ver;
  367.  
  368.     if ($^V and $^V ge v5.8.0) {
  369.     my %osmap = (MSWin32 => "windows");
  370.     my $plat = $osmap{$^O} || $^O;
  371.     $verplat1 = "-$ver-$plat";
  372.     $verplat2 = "$ver-$plat";
  373.     }
  374.     my %reps = (
  375.     ppm3 => sprintf($ppm3, $verplat1),
  376.     ppm2 => sprintf($ppm2, $verplat1),
  377.     www  => sprintf($www, $verplat2),
  378.     );
  379.     return $reps{$rep};
  380. }
  381.  
  382. sub config_file_stub {
  383.     my $name = shift;
  384.     if ($name eq 'clientlib') {
  385.     my $tmp = $ENV{TEMP} || $^O eq 'MSWin32' ? 'C:\TEMP' : '/tmp';
  386.     my $server = repository('ppm3');
  387.     return <<END;
  388. downloadbytes: 16384
  389. profile_enable: 0
  390. profile_server: $server
  391. rebuildhtml: 0
  392. tempdir: $tmp
  393. tracefile: ppm3.log
  394. tracelvl: 0
  395. END
  396.     }
  397.     elsif ($name eq 'cmdline') {
  398.     # This is actually a little bit wrong, since there are (potentially)
  399.     # multiple frontends. Each frontend should really be responsible for
  400.     # its own configuration data. Still, I don't care all that much.
  401.     return <<'END';
  402. case-sensitivity: 0
  403. fields: name version abstract
  404. follow-install: 1
  405. force-install: 0
  406. install-verbose: 1
  407. max_history: 100
  408. page-lines: 24
  409. pager: ""
  410. prompt-context: 0
  411. prompt-slotsize: 11
  412. prompt-verbose: 0
  413. remove-verbose: 1
  414. sort-field: name
  415. upgrade-verbose: 1
  416. verbose-startup: 1
  417. END
  418.     }
  419.     elsif ($name eq 'instkey') {
  420.     my $txt = do {
  421.         require PPM::Sysinfo;
  422.         my $DATA = PPM::Sysinfo::generate_inst_key();
  423.         return PPM::YAML::serialize($DATA);
  424.     };
  425.     }
  426.     elsif ($name eq 'repositories') {
  427.     my $url_ppm2 = repository('ppm2');
  428.     my $url_ppm3 = repository('ppm3');
  429.     return <<END;
  430. ActiveState Package Repository: %
  431.     url: $url_ppm3
  432. ActiveState PPM2 Repository: %
  433.     url: $url_ppm2
  434. END
  435.     }
  436.     elsif ($name eq 'targets') {
  437.     # Targets.cfg is the only oddball, because there are multiple targets
  438.     # out there. What we do is this: at build time (at ActiveState) we
  439.     # write a targets.cfg file which is to be relocated at install time.
  440.     # Instead of installing it using a post-install script, ppm3-bin will
  441.     # now look for it next to the binary, and use its contents as the stub
  442.     # targets.cfg file. If the user deletes their .ActiveState/PPM
  443.     # directory, this will magically reappear.
  444.     require FindBin;
  445.     my $f = "$FindBin::Bin/ppm3-bin.cfg";
  446.     my $txt;
  447.     if (-f $f) {
  448.         local *STUB;
  449.         open STUB, $f    or die "can't open $f: $!";
  450.         $txt = do { local $/; <STUB> };
  451.         close STUB        or die "can't close $f: $!";
  452.     }
  453.     return $txt;
  454.     }
  455.     return '';    # unrecognized file
  456. }
  457.  
  458. 1;
  459.