home *** CD-ROM | disk | FTP | other *** search
/ Chip: Windows 2000 Professional Resource Kit / W2KPRK.iso / apps / perl / ActivePerl.exe / _setup.lib / ASSetup.pm < prev    next >
Encoding:
Perl POD Document  |  1999-10-14  |  30.4 KB  |  1,087 lines
  1. #
  2. # ASSetup.pm
  3. #
  4. # Author: Michael Smith (mikes@ActiveState.com)
  5. #
  6. # Copyright ⌐ 1999 ActiveState Tool Corp., all rights reserved.
  7. #
  8. ###############################################################################
  9. package ASSetup;
  10.  
  11. use PPM;
  12. use XML::PPMConfig;
  13. use XML::Parser;
  14. use Win32::OLE;
  15. use Win32::Process;
  16. use Data::Dumper;
  17. use Win32::Registry;
  18. eval('use Win32::Service;');
  19.     
  20. use constant SERVICE_STARTED => 4;
  21. use constant SERVICE_STOPPED => 1;
  22.  
  23.  
  24. ###############################################################################
  25. #
  26. ###############################################################################
  27. sub ModifyRegValue {
  28.     my ($path, $data, $action, $duplicate_ok) = @_;
  29.     my ($root, $path, $value) = ($path =~ m#(.*?)\\(.*)\\(.*)#);
  30.     $root = ${"main::$root"};
  31.     return "Error: invalid Registry root : $root!" unless defined $root;
  32.     my $key;
  33.     $root->Open($path, $key) || return "Error: $! !";
  34.     my $olddata;
  35.     my $type;
  36.     $key->QueryValueEx($value, $type, $olddata) || return "Error: $! !";
  37.     if($olddata =~ m#$data# && $action ne 'REPLACE') {
  38.     unless($duplicate_ok) {
  39.         return '0';
  40.     }
  41.     }
  42.  
  43.     if($action eq 'PREPEND') {
  44.     $data .= $olddata;
  45.     }
  46.     elsif($action eq 'APPEND') {
  47.     $data = $olddata . $data;
  48.     }
  49.     elsif($action eq 'REPLACE') {
  50.     # Do nothing here
  51.     }
  52.     else {
  53.     return "Error: unknown action : $action";
  54.     }
  55.  
  56.     $key->SetValueEx($value, 0, $type, $data) || return "Error: $! !";
  57.     $key->Close();
  58.     return '1';
  59. }
  60.  
  61. ###############################################################################
  62. #
  63. ###############################################################################
  64. sub addDependent {
  65.     my ($data_file, $dependent) = @_;
  66.     open(DATA, "<$data_file") or 
  67.     return "Error: reading $data_file! $!";
  68.     map($data .= $_, <DATA>);
  69.     close(DATA);
  70.     eval($data);
  71.  
  72.     return if grep /^$dependent$/i, @$dependents;
  73.  
  74.     push (@$dependents, $dependent);
  75.  
  76.     my $data = Data::Dumper->Dump(
  77.         [
  78.           $app_name, $is_uninstall_string, \@$path_info,
  79.           \@$iis_virt_dir, \%$iis_script_map, $ns_config_dir,
  80.           \%$lines_in_file, \@$directory, \@$file, \@$dependents
  81.         ],
  82.  
  83.         [
  84.           "app_name", "is_uninstall_string", "path_info",
  85.           "iis_virt_dir", "iis_script_map", "ns_config_dir",
  86.           "lines_in_file", "directory", "file", "dependents"
  87.         ]
  88.     );
  89.  
  90.     open(DATA, ">$data_file");
  91.     print DATA $data;
  92.     close(DATA);
  93.     return;
  94. }
  95.  
  96. ###############################################################################
  97. #
  98. ###############################################################################
  99. sub shellExec {
  100.     system(@_) == 0 or 
  101.     return "Error: Status returned from $_[0] : $?";
  102.  
  103.     my $obj;
  104.     my $appname = shift;
  105.     my $cmdline = $appname . ' ' . join(' ', @_);
  106.     my $iflags     = 0;
  107.     my $cflags     = NORMAL_PRIORITY_CLASS;
  108.     my $curdir  = '.';
  109.     Win32::Process::Create($obj,$appname,$cmdline,$iflags,$cflags,$curdir) ||
  110.     return 'Error: ' . Win32::FormatMessage( Win32::GetLastError() );
  111.     $obj->Wait(INFINITE);
  112.  
  113.     my $exit_code;
  114.     $obj->GetExitCode($exit_code);
  115.     return "Error: $appname exited with code: $exit_code" if
  116.     $exit_code != 0;
  117. }
  118.  
  119. ###############################################################################
  120. #
  121. ###############################################################################
  122. sub EvalScript {
  123.     my ($script_name) = shift;
  124.     local (@ARGV) = @_;
  125.     do $script_name;
  126.     return "Error: $@" if $@ ne '';
  127. }
  128.  
  129. ###############################################################################
  130. #
  131. ###############################################################################
  132. sub StopService {
  133.    
  134.     return if Win32::IsWin95;
  135.     
  136.     my $service = shift;
  137.     my $status = {};
  138.     my $rv = Win32::Service::GetStatus('', $service, $status);
  139.     if(!$rv) {
  140.     return 'Error: ' . Win32::FormatMessage(Win32::GetLastError());            
  141.     }
  142.  
  143.     if($status->{'CurrentState'} != SERVICE_STOPPED) {
  144.     $rv = Win32::Service::StopService('', $service);
  145.     if(!$rv) {
  146.         return 'Error: ' . Win32::FormatMessage(Win32::GetLastError());
  147.     }
  148.  
  149.     while($status->{'CurrentState'} != SERVICE_STOPPED) { 
  150.         sleep(5); 
  151.         $rv = Win32::Service::GetStatus('', $service, $status);
  152.         if(!$rv) {
  153.         return 'Error: ' . Win32::FormatMessage(Win32::GetLastError());
  154.         }
  155.     }
  156.     }
  157.     return;
  158. }
  159.  
  160. ###############################################################################
  161. #
  162. ###############################################################################
  163. sub StartService {
  164.     
  165.     return if Win32::IsWin95;
  166.    
  167.     my $service = shift;
  168.     my $status = {};
  169.     my $rv = Win32::Service::GetStatus('', $service, $status);
  170.     if(!$rv) {
  171.     return 'Error: ' . Win32::FormatMessage(Win32::GetLastError());            
  172.     }
  173.  
  174.     if($status->{'CurrentState'} != SERVICE_STARTED) {
  175.     $rv = Win32::Service::StartService('', $service);
  176.     if(!$rv) {
  177.         return 'Error: ' . Win32::FormatMessage(Win32::GetLastError());            
  178.     }
  179.  
  180.     while($status->{'CurrentState'} != SERVICE_STARTED) {
  181.         sleep(5);
  182.         $rv = Win32::Service::GetStatus('', $service, $status);
  183.         if(!$rv) {
  184.             return 'Error: ' . Win32::FormatMessage(Win32::GetLastError());            
  185.         }
  186.     }
  187.     }
  188.     return;
  189. }
  190.  
  191. ###############################################################################
  192. # Config.pm values to propogate when doing an upgrade installation
  193. ###############################################################################
  194. my @propagateThese = qw(
  195.     ar
  196.     archlib
  197.     archlibexp
  198.     awk
  199.     bash
  200.     bin
  201.     binexp
  202.     bison
  203.     byacc
  204.     cat
  205.     cc
  206.     cf_by
  207.     cf_email
  208.     cp
  209.     cryptlib
  210.     csh
  211.     date
  212.     echo
  213.     egrep
  214.     emacs
  215.     expr
  216.     find
  217.     flex
  218.     full_csh
  219.     full_sed
  220.     gccversion
  221.     glibpth
  222.     gzip
  223.     incpath
  224.     inews
  225.     installarchlib
  226.     installbin
  227.     installhtmldir
  228.     installhtmlhelpdir
  229.     installman1dir
  230.     installman3dir
  231.     installprivlib
  232.     installscript
  233.     installsitearch
  234.     installsitelib
  235.     ksh
  236.     ld
  237.     lddlflags
  238.     ldflags
  239.     less
  240.     libc
  241.     libpth
  242.     ln
  243.     lns
  244.     loincpth
  245.     lolibpth
  246.     lp
  247.     lpr
  248.     ls
  249.     mail
  250.     mailx
  251.     make
  252.     man1dir
  253.     man1direxp
  254.     man3dir
  255.     man3direxp
  256.     mkdir
  257.     more
  258.     mv
  259.     mydomain
  260.     myhostname
  261.     myuname
  262.     pager
  263.     perlpath
  264.     prefix
  265.     prefixexp
  266.     privlib
  267.     privlibexp
  268.     rm
  269.     rmail
  270.     scriptdir
  271.     scriptdirexp
  272.     sed
  273.     sendmail
  274.     sh
  275.     sitearch
  276.     sitearchexp
  277.     sitelib
  278.     sitelibexp
  279.     touch
  280.     tr
  281.     usrinc
  282.     vi
  283.     xlibpth
  284.     zcat
  285.     zip
  286. );
  287.  
  288. ###############################################################################
  289. #
  290. ###############################################################################
  291. sub mergeConfig {
  292.     my $file1 = shift;
  293.     my $file2 = shift;
  294.  
  295.     open(FILE1, "<$file1")
  296.     || return "Error: Could not open file $file1 : $!";
  297.     
  298.     my $foundConfigBegin = 0;
  299.     my $foundConfigEnd = 0;
  300.     my %Config1 = ();
  301.     while(<FILE1>) {
  302.     chomp;
  303.     if (!$foundConfigBegin && /^my \$config_sh = <<'!END!';$/) {
  304.         $foundConfigBegin = 1;
  305.         next;
  306.     } 
  307.     elsif (!$foundConfigEnd && /^!END!$/) {
  308.         last;
  309.     }
  310.     next if(!$foundConfigBegin);
  311.     my ($name, $value) = split(/=/, $_, 2);
  312.     if(grep(/$name/, @propagateThese)) {
  313.         $Config1{$name} = $value;
  314.     }
  315.     }
  316.     close(FILE1);
  317.  
  318.     open(FILE2, "+<$file2")
  319.     || return "Error: Could not open file $file2 : $!";
  320.  
  321.     $foundConfigBegin = 0;
  322.     $foundConfigEnd = 0;
  323.     my @Config2 = ();
  324.     while(<FILE2>) {
  325.     my $line = $_;
  326.     chomp($line);
  327.     if (!$foundConfigBegin && $line =~ /^my \$config_sh = <<'!END!';$/) {
  328.         $foundConfigBegin = 1;
  329.     } 
  330.     elsif (!$foundConfigEnd && $line =~ /^!END!$/) {
  331.         $foundConfigEnd = 1;
  332.     }
  333.     elsif ($foundConfigBegin && !$foundConfigEnd) {
  334.         my ($name, $value) = split(/=/, $line, 2);
  335.         if(exists $Config1{$name} && length($Config1{$name}) > 0) {
  336.         $line = "$name=$Config1{$name}";
  337.         }
  338.     }
  339.     push(@Config2, $line . "\n");
  340.     }
  341.     truncate(FILE2, 0);
  342.     seek(FILE2, 0, 0);
  343.     print FILE2 (@Config2);
  344.     close(FILE2);
  345.     return; 
  346. }
  347.  
  348. ###############################################################################
  349. #
  350. ###############################################################################
  351. sub mergePPMConfig {
  352.     my $file1 = shift;
  353.     my $file2 = shift;
  354.     my $parser = new XML::Parser(Style => 'Objects', Pkg => 'XML::PPMConfig');
  355.     my $Config1 = $parser->parsefile($file1);
  356.     my $Config2 = $parser->parsefile($file2);
  357.     
  358.     my $i = 0;
  359.     foreach my $elem (@{$Config1->[0]->{Kids}}) {
  360.         if((ref $elem) =~ /.*::PACKAGE$/) {
  361.         if (! existsInConfig('PACKAGE', $elem->{NAME}, $Config2)) {
  362.             splice(@{$Config2->[0]->{Kids}}, $i, 0, $elem);
  363.         }
  364.         }
  365.         ++$i;
  366.     }
  367.     
  368.     open(FILE, ">$file2")
  369.         || return "Error: Could not open $file2 : $!";
  370.     select(FILE);
  371.     my $Config_ref = bless($Config2->[0], "XML::PPMConfig::PPMCONFIG");
  372.     $Config_ref->output();
  373.     close(FILE);
  374.     return;
  375. }
  376.  
  377. ###############################################################################
  378. #
  379. ###############################################################################
  380. sub existsInConfig {
  381.     my $element = shift;
  382.     my $name = shift;
  383.     my $config = shift;
  384.  
  385.     foreach my $elem (@{$config->[0]->{Kids}}) {
  386.         return 1 
  387.         if ((ref $elem) =~ /.*::$element$/ && $elem->{NAME} eq $name);
  388.     }
  389.     return 0;
  390. }
  391.  
  392.  
  393. #
  394. # Uninstall.pm
  395. #
  396. # Author: Michael Smith (mikes@ActiveState.com)
  397. #
  398. # Copyright ⌐ 1998 ActiveState Tool Corp., all rights reserved.
  399. #
  400. ###############################################################################
  401. package ASSetup::Uninstall;
  402.  
  403. #
  404. # Uninstall configuration
  405. #
  406. ###############################################################################
  407. my $data_file = 'p_uninst.dat';
  408. my $data_path = '';
  409. my $app_name  = '';
  410.  
  411. #
  412. # Things we need to track
  413. #
  414. ###############################################################################
  415.  
  416. # InstallShiel uninstall data file
  417. $is_uninstall_string;
  418.  
  419. # Directories added to the PATH environment variable
  420. @path_info;
  421.  
  422. # IIS4 configuration information
  423. @iis_virt_dir;
  424. %iis_script_map;
  425.  
  426. # Netscape configuration information
  427. $ns_config_dir;
  428.  
  429. %lines_in_file;
  430.  
  431. # Additional files and directories
  432. @directory;
  433. @file;
  434.  
  435. #
  436. # Function defininitions
  437. #
  438. ###############################################################################
  439. sub LoadData {
  440.     return unless -e "$data_path/$data_file";
  441.     return unless open(FILE, "< $data_path/$data_file");
  442.     local $/ = undef;
  443.     my $data = <FILE>;
  444.     close(FILE);
  445.     eval($data);
  446. }
  447.  
  448. # Set_DataPath
  449. sub Set_DataPath {
  450.     $data_path = $_[0];
  451. }
  452.  
  453. # Set_AppName
  454. sub Set_AppName {
  455.     $app_name = $_[0];
  456. }
  457.  
  458. # Get_DataFile
  459. sub Get_DataFile {
  460.     return "$data_path/$data_file";
  461. }
  462.  
  463. # Set_IS_UninstallString
  464. sub Set_IS_UninstallString {
  465.     $is_uninstall_string = $_[0];
  466. }
  467.  
  468. # Add_PathInfo
  469. sub Add_PathInfo {
  470.     push(@path_info, $_[0]);
  471. }
  472.  
  473. # Add_IIS_VirtDir
  474. sub Add_IIS_VirtDir {
  475.     push(@iis_virt_dir, $_[0]);
  476. }
  477.  
  478. # Add_IIS_ScriptMap
  479. sub Add_IIS_ScriptMap {
  480.     my $virt_dir = $_[0];
  481.     my $file_ext = $_[1];
  482.     $virt_dir = '.' if $virt_dir eq '';
  483.     push(@{$iis_script_map{$virt_dir}}, $file_ext);
  484. }
  485.  
  486. # Set_NS_ConfigDir
  487. sub Set_NS_ConfigDir {
  488.     $ns_config_dir = $_[0];
  489. }
  490.  
  491. # Add_Line
  492. sub Add_Line {
  493.     my ($file, $line) = @_;
  494.     $file = lc($file);
  495.     push(@{$lines_in_file{$file}}, $line);
  496. }
  497.  
  498. # Add_File
  499. sub Add_File {
  500.     push(@file, $_[0]);
  501. }
  502.  
  503. # Add_Directory
  504. sub Add_Directory {
  505.     push(@directory, $_[0]);
  506. }
  507.  
  508. # Write_Data
  509. sub Write_Data {
  510.    my $data = Data::Dumper->Dump(
  511.         [
  512.           $app_name,
  513.           $is_uninstall_string,
  514.           \@path_info,
  515.           \@iis_virt_dir,
  516.           \%iis_script_map,
  517.           $ns_config_dir,
  518.           \%lines_in_file,
  519.           \@directory,
  520.           \@file
  521.         ],
  522.  
  523.         [qw(
  524.           app_name
  525.           is_uninstall_string
  526.           path_info
  527.           iis_virt_dir
  528.           iis_script_map
  529.           ns_config_dir
  530.           lines_in_file
  531.           directory
  532.           file
  533.         )]
  534.     );
  535.  
  536.     open(DATA, ">$data_path/$data_file");
  537.     print DATA $data;
  538.     close(DATA);
  539. }
  540.  
  541. ###############################################################################
  542. # Company : ActiveState Tool Corp.
  543. # Author  : James A. Snyder ( James@ActiveState.com )
  544. # Date    : 7/11/98
  545.     # Copyright ⌐ 1998 ActiveState Tool Corp., all rights reserved.
  546.     #
  547.  
  548. ###############################################################################
  549. # MetabaseConfig.pm
  550.  
  551. package ASSetup::MetabaseConfig;
  552. ###############################################################################
  553. # ScriptMap flags
  554.  
  555. sub MD_SCRIPTMAPFLAG_SCRIPT_ENGINE{1};
  556. sub MD_SCRIPTMAPFLAG_CHECK_PATH_INFO{4};
  557.  
  558. ###############################################################################
  559. # Access Permission Flags
  560.  
  561. sub MD_ACCESS_READ               { 0x00000001 }; #   // Allow for Read
  562. sub MD_ACCESS_WRITE              { 0x00000002 }; #   // Allow for Write
  563. sub MD_ACCESS_EXECUTE            { 0x00000004 }; #   // Allow for Execute
  564. sub MD_ACCESS_SCRIPT             { 0x00000200 }; #   // Allow for Script execution
  565. sub MD_ACCESS_NO_REMOTE_WRITE    { 0x00000400 }; #   // Local host access only
  566. sub MD_ACCESS_NO_REMOTE_READ     { 0x00001000 }; #   // Local host access only
  567. sub MD_ACCESS_NO_REMOTE_EXECUTE  { 0x00002000 }; #   // Local host access only
  568. sub MD_ACCESS_NO_REMOTE_SCRIPT   { 0x00004000 }; #   // Local host access only
  569.  
  570.     
  571. ###############################################################################
  572.  
  573. $ASSetup::MetabaseConfig::LogObject = undef;
  574.  
  575. # Set the reference to the Log object
  576.  
  577. sub SetLogObject {
  578.     $ASSetup::MetabaseConfig::LogObject = shift;
  579.     if(!$ASSetup::MetabaseConfig::LogObject->isa("Log")) {
  580.     $ASSetup::MetabaseConfig::LogObject = undef;
  581.     }
  582. }
  583.  
  584.  
  585. $ASSetup::MetabaseConfig::StatusStarted = 4;
  586. $ASSetup::MetabaseConfig::StatusStopped = 1;
  587.  
  588.  
  589. sub StopIISAdmin {
  590.     my $output = `net stop IISAdmin /y`;
  591.     if($?) {
  592.     return "Error: oops there was a problem stopping the IISAdmin service\n";
  593.     }
  594.  
  595.     $output = `net start`;
  596.     my @output = split($/, $output);
  597.     my $grep_results = grep(/IIS Admin Service/, @output);
  598.     if($grep_results) {
  599.     return "Error: oops we thought we stopped the IISAdmin service when we didn't\n";
  600.     }
  601.  
  602. #        MetabaseConfig::StopService('W3SVC') || return "Error stopping the W3SVC service";
  603. #        MetabaseConfig::StopService('MSFTPSVC') || return "Error stopping the MSFTPSVC service";
  604. #        MetabaseConfig::StopService('IISADMIN') || return "Error stopping the IISADMIN service";
  605. #        my $result = `net stop IISADMIN /y`;
  606. }
  607.  
  608. sub StartIISAdmin {
  609.     MetabaseConfig::StartService('IISADMIN') || return "Error starting the IISADMIN service";
  610.     MetabaseConfig::StartService('W3SVC') || return "Error starting the W3SVC service";
  611.     MetabaseConfig::StartService('MSFTPSVC') || return "Error starting the MSFTPSVC service";
  612. #        my $result = `net start IISADMIN /y`;
  613. #        $result = `net start W3SVC /y`;
  614. #        $result = `net start MSFTPSVC /y`;
  615. }
  616.     
  617. ###############################################################################
  618. # StopIISAdmin();
  619.  
  620. sub StopService {
  621.     my $service = shift;
  622.     my $status = {};
  623.     my $rv = Win32::Service::GetStatus('', $service, $status);
  624.     if(!$rv) {
  625.         print Win32::FormatMessage(Win32::GetLastError()), "\n";            
  626.         $ASSetup::MetabaseConfig::LogObject->ERROR("Could not GetStatus of $service service in first attempt MetabaseConfig::StopIISAdmin: $!") if $ASSetup::MetabaseConfig::LogObject;
  627.         return 1;
  628.     }
  629.  
  630.     if($status->{'CurrentState'} != $ASSetup::MetabaseConfig::StatusStopped) {
  631.     $rv = Win32::Service::StopService('', $service);
  632.     if(!$rv) {
  633.         print Win32::FormatMessage(Win32::GetLastError()), "\n";            
  634.         $ASSetup::MetabaseConfig::LogObject->ERROR("Could not stop $service service in MetabaseConfig::StopIISAdmin: $!") if $ASSetup::MetabaseConfig::LogObject;
  635.         return $rv;
  636.     }
  637.  
  638.     while($status->{'CurrentState'} != $ASSetup::MetabaseConfig::StatusStopped) {
  639.         sleep(10);
  640.         $rv = Win32::Service::GetStatus('', $service, $status);
  641.         if(!$rv) {
  642.         print Win32::FormatMessage(Win32::GetLastError()), "\n";            
  643.         $ASSetup::MetabaseConfig::LogObject->ERROR("Could not GetStatus of $service service in MetabaseConfig::StopIISAdmin: $!") if $ASSetup::MetabaseConfig::LogObject;
  644.         return $rv;
  645.         }
  646.     }
  647.     }
  648.  
  649.     $ASSetup::MetabaseConfig::LogObject->TRACE("$service service is stopped in MetabaseConfig::StopIISAdmin") if $ASSetup::MetabaseConfig::LogObject;
  650.     return 1;
  651. }
  652.  
  653. ###############################################################################
  654. # StartIISAdmin();
  655.  
  656. sub StartService {
  657.     my $service = shift;
  658.     my $status = {};
  659.     my $rv = Win32::Service::GetStatus('', $service, $status);
  660.     if(!$rv) {
  661.         $ASSetup::MetabaseConfig::LogObject->ERROR("Could not GetStatus of $service service in first attempt MetabaseConfig::StartIISAdmin: $!") if $ASSetup::MetabaseConfig::LogObject;
  662.         return 1;
  663.     }
  664.  
  665.     if($status->{'CurrentState'} != $ASSetup::MetabaseConfig::StatusStarted) {
  666.     $rv = Win32::Service::StartService('', $service);
  667.     if(!$rv) {
  668.         $ASSetup::MetabaseConfig::LogObject->ERROR("Could not start $service service in MetabaseConfig::StartIISAdmin: $!") if $ASSetup::MetabaseConfig::LogObject;
  669.         return $rv;
  670.     }
  671.  
  672.     while($status->{'CurrentState'} != $ASSetup::MetabaseConfig::StatusStarted) {
  673.         sleep(5);
  674.         $rv = Win32::Service::GetStatus('', $service, $status);
  675.         if(!$rv) {
  676.         $ASSetup::MetabaseConfig::LogObject->ERROR("Could not GetStatus of $service service in MetabaseConfig::StartIISAdmin: $!") if $ASSetup::MetabaseConfig::LogObject;
  677.         return $rv;
  678.         }
  679.     }
  680.     }
  681.  
  682.     $ASSetup::MetabaseConfig::LogObject->TRACE("$service service is started in MetabaseConfig::StartIISAdmin") if $ASSetup::MetabaseConfig::LogObject;
  683.     return 1;
  684. }
  685.  
  686.  
  687. @ASSetup::MetabaseConfig::ServerStash = ();
  688.  
  689. ###############################################################################
  690. # StashRunningServers()
  691.  
  692. sub StashRunningServers {
  693.     my $index = 1;
  694.     my $path = 'IIS://localhost/W3SVC/';
  695.     my $testPath = $path . $index;
  696.     my $server;
  697.  
  698.     $ASSetup::MetabaseConfig::LogObject->TRACE("Stashing running web servers in MetabaseConfig::StashRunningServers") if $ASSetup::MetabaseConfig::LogObject;
  699.     while ( ($server = Win32::OLE->GetObject($testPath)) )
  700.     {
  701.     $ASSetup::MetabaseConfig::ServerStash[$index] = ($server->Status() == 2);
  702.     $index++;
  703.     $testPath = $path . $index;
  704.     }
  705. }
  706.  
  707.     
  708. ###############################################################################
  709. # StartStashedServers()
  710.  
  711. sub StartStashedServers {
  712.     my $index = 1;
  713.     my $path = 'IIS://localhost/W3SVC/';
  714.     my $testPath = $path . $index;
  715.     my $server;
  716.     my $wasStarted;
  717.     
  718.     $ASSetup::MetabaseConfig::LogObject->TRACE("Starting stashed web servers MetabaseConfig::StartStashedServers") if $ASSetup::MetabaseConfig::LogObject;
  719.     foreach $wasStarted (@ASSetup::MetabaseConfig::ServerStash) {
  720.     if($wasStarted == 1) {
  721.         $server = Win32::OLE->GetObject($testPath);
  722.         if(!$server) {
  723.         $ASSetup::MetabaseConfig::LogObject->ERROR("Could not GetObject($testPath) in MetabaseConfig::StartStashedServers: " . Win32::OLE->LastError()) if $ASSetup::MetabaseConfig::LogObject;
  724.         } else {
  725.         $server->Start();
  726.         }
  727.     }
  728.     $index++;
  729.     $testPath = $path . $index;
  730.     }
  731. }
  732.  
  733. ###############################################################################
  734. # StartWWW( $dwWebServerID );
  735.  
  736. sub StartWWW
  737. {
  738.     my $serverID = $_[0];
  739.     my $path   = 'IIS://localhost/W3SVC/' . $serverID;
  740.     my $server =  Win32::OLE->GetObject($path);
  741.     $ASSetup::MetabaseConfig::LogObject->TRACE("Starting WWWServer: $path") if $ASSetup::MetabaseConfig::LogObject;
  742.     if(!$server) {
  743.     $ASSetup::MetabaseConfig::LogObject->ERROR("Could not GetObject($path) in MetabaseConfig::StartWWW: " . Win32::OLE->LastError()) if $ASSetup::MetabaseConfig::LogObject;
  744.     return undef;
  745.     }
  746.     $server->Start();
  747. }
  748.  
  749. ###############################################################################
  750. # StopWWW( $dwWebServerID );
  751.  
  752. sub StopWWW
  753. {
  754.     my $serverID = $_[0];
  755.     my $path   = 'IIS://localhost/W3SVC/' . $serverID;
  756.     my $server =  Win32::OLE->GetObject($path);
  757.     $ASSetup::MetabaseConfig::LogObject->TRACE("Stopping WWWServer: $path") if $ASSetup::MetabaseConfig::LogObject;
  758.     if(!$server) {
  759.     $ASSetup::MetabaseConfig::LogObject->ERROR("Could not GetObject($path) in MetabaseConfig::StopWWW: " . Win32::OLE->LastError()) if $ASSetup::MetabaseConfig::LogObject;
  760.             return undef;
  761.         }
  762.     $server->Stop();
  763. }
  764.  
  765. ###############################################################################
  766. # $arrayRef = EnumWebServers();
  767.  
  768. sub EnumWebServers
  769. {
  770.     my $index = 1;
  771.     my $path = 'IIS://localhost/W3SVC/';
  772.     my $testPath = $path . $index;
  773.     my $server;
  774.     my @webServers = ();
  775.  
  776.     while ( ($server=Win32::OLE->GetObject($testPath)) )
  777.     {
  778.     $webServers[$index] = $server->{ServerComment};
  779.     $index++;
  780.     $testPath = $path . $index;
  781.     }
  782.  
  783.     return \@webServers;
  784. }
  785.  
  786. ###############################################################################
  787. # GetFileExtMapping($dwServerID, $szVirDir, $szFileExt)
  788.  
  789. sub GetFileExtMapping
  790. {
  791.     if( @_ < 3 )
  792.     {
  793. #            die "Not enough Parameters for GetFileExtMapping()\n";
  794.     }
  795.  
  796.     my $server        = '';
  797.     my $szVirDirPath  = '';
  798.     my $dwServerID    = shift;
  799.     my $szVirDir      = shift;
  800.     my $szFileExt     = shift;
  801.         my $scriptMap      = '';
  802.  
  803.     # Create string that contains the Path to our Virutal directory or the WebServer's Root
  804.     $szVirDirPath = 'IIS://localhost/W3SVC/' . $dwServerID . '/ROOT';
  805.     $ASSetup::MetabaseConfig::LogObject->TRACE("Getting file extension mapping: $szFileExt") if $ASSetup::MetabaseConfig::LogObject;
  806.     if( length($szVirDir) )
  807.     {
  808.     $szVirDirPath = $szVirDirPath . "/" . $szVirDir;
  809.     }
  810.  
  811.     # Get the IIsVirtualDir Automation Object
  812.     $server = Win32::OLE->GetObject($szVirDirPath);
  813.     if(!$server) {
  814.     $ASSetup::MetabaseConfig::LogObject->ERROR("Could not GetObject($szVirDirPath) in MetabaseConfig::GetFileExtMapping: " . Win32::OLE->LastError) if $ASSetup::MetabaseConfig::LogObject;
  815.     return;
  816.     }
  817.         
  818.     foreach $scriptMap (@{$server->{ScriptMaps}}) {
  819.     if($scriptMap =~ /^$szFileExt,/i) {
  820.         return $scriptMap;
  821.     }
  822.     }
  823. }
  824.  
  825.  
  826. ###############################################################################
  827. # RemoveFileExtMapping($dwServerID, $szVirDir, $szFileExt)
  828.  
  829. sub RemoveFileExtMapping
  830. {
  831.     if( @_ < 3 )
  832.     {
  833. #            die "Not enough Parameters for AddFileExtMapping()\n";
  834.     }
  835.  
  836.     my $szVirDirPath    = '';
  837.     my @newScriptMap  = ();
  838.     my $dwServerID    = shift;
  839.     my $szVirDir      = shift;
  840.     my $szFileExt     = shift;
  841.     my $virDir;
  842.         my $ScriptMap      = '';
  843.  
  844.         if(GetFileExtMapping($dwServerID, $szVirDir, $szFileExt) eq '') {
  845.             return 1;
  846.         }
  847.  
  848.     # Create string that contains the Path to our Virutal directory or the WebServer's Root
  849.     $szVirDirPath = 'IIS://localhost/W3SVC/' . $dwServerID . '/ROOT';
  850.  
  851.         if( length($szVirDir) )
  852.     {
  853.     $szVirDirPath = $szVirDirPath . "/" . $szVirDir;
  854.     }
  855.  
  856.     # Get the IIsVirtualDir Automation Object
  857.     $virDir = Win32::OLE->GetObject($szVirDirPath);
  858.     if(!$virDir) {
  859.     $ASSetup::MetabaseConfig::LogObject->ERROR("Could not GetObject($szVirDirPath) in MetabaseConfig::RemoveFileExtMapping: " . Win32::OLE->LastError()) if $ASSetup::MetabaseConfig::LogObject;
  860.     return;
  861.     }
  862.         
  863.  
  864.     $ASSetup::MetabaseConfig::LogObject->TRACE("Removing file extension mapping: $szFileExt") if $ASSetup::MetabaseConfig::LogObject;
  865.     foreach $ScriptMap (@{$virDir->{ScriptMaps}}) {
  866.     if($ScriptMap !~ /^$szFileExt,/i) {
  867.         push(@newScriptMap, $ScriptMap);
  868.     }
  869.     }
  870.  
  871.     # set the ScriptsMaps property to our new script map array
  872.     $virDir->{ScriptMaps} = \@newScriptMap;
  873.  
  874.     # Save the new script mappings
  875.     $virDir->SetInfo();
  876. }
  877.  
  878. ###############################################################################
  879. # AddFileExtMapping($dwServerID, $szVirDir, $szFileExt, $lpszExec, $dwFlags, $szMethodExclusions)
  880.  
  881. sub AddFileExtMapping
  882. {
  883.     if( @_ < 6 )
  884.     {
  885. #            die "Not enough Parameters for AddFileExtMapping()\n";
  886.     }
  887.  
  888.     my $server        = '';
  889.     my $szVirDirPath    = '';
  890.     my $scriptMapping = '';
  891.     my @newScriptMap  = ();
  892.     my $dwServerID    = shift;
  893.     my $szVirDir      = shift;
  894.     my $szFileExt     = shift;
  895.     my $szExecPath    = shift;
  896.     my $dwFlags       = shift;
  897.     my $szMethodExc   = shift;
  898.  
  899.         if(GetFileExtMapping($dwServerID, $szVirDir, $szFileExt) ne '') {
  900.             return 1;
  901.         }
  902.         
  903.     # Create string that contains the Path to our Virutal directory or the WebServer's Root
  904.     $szVirDirPath = 'IIS://localhost/W3SVC/' . $dwServerID . '/ROOT';
  905.     if( length($szVirDir) )
  906.     {
  907.     $szVirDirPath = $szVirDirPath . "/" . $szVirDir;
  908.     }
  909.     
  910.         # Get the IIsVirtualDir Automation Object
  911.     $server = Win32::OLE->GetObject($szVirDirPath);
  912.     if(!$server) {
  913.     $ASSetup::MetabaseConfig::LogObject->ERROR("Could not GetObject($szVirDirPath) in MetabaseConfig::AddFileExtMapping: " . Win32::OLE->LastError()) if $ASSetup::MetabaseConfig::LogObject;
  914.     return;
  915.     }
  916.         
  917.     # create our new script mapping entry
  918.     $scriptMapping = "$szFileExt,$szExecPath,$dwFlags";
  919.  
  920.     # make sure the length of szMethodExc is greater than 2 before adding szMethodExc to the script mapping
  921.     if( length($szMethodExc) > 2 )
  922.     {
  923.     $scriptMapping = $scriptMapping . ",$szMethodExc";
  924.     }
  925.  
  926.     $ASSetup::MetabaseConfig::LogObject->TRACE("Adding file extension mapping: $scriptMapping") if $ASSetup::MetabaseConfig::LogObject;
  927.     @newScriptMap = @{$server->{ScriptMaps}};
  928.     push(@newScriptMap, $scriptMapping);
  929.     
  930.     $server->{ScriptMaps} = \@newScriptMap;
  931.  
  932.     # Save the new script mappings
  933.     $server->SetInfo();
  934. }
  935.  
  936. ###############################################################################
  937. # CreateVirDir( $dwServerID, $szPath, $szName, $dwAccessPerm, $bEnableDirBrowse, $bAppRoot);
  938.  
  939. sub CreateVirDir
  940. {
  941.     if( @_ < 6 )
  942.     {
  943. #            die "Not enough Parameters for CreateVirDir()\n";
  944.     }
  945.  
  946.     # Local Variables
  947.     my $serverPath;
  948.     my $server;
  949.     my $virDir;
  950.     my $dwServerID       = shift;
  951.     my $szPath           = shift;
  952.     my $szName           = shift;
  953.     my $dwAccessPerm     = shift;
  954.     my $bEnableDirBrowse = shift;
  955.     my $bAppRoot         = shift;
  956.  
  957.  
  958.     if($szPath eq "" || $szName eq "")
  959.     {
  960.     die "Incorrect Parameter to CreateVirDir() ...\n";
  961.     }
  962.  
  963.     # Create string that contains the Path to our Webserver's Root
  964.     $serverPath = 'IIS://localhost/W3SVC/' . $dwServerID . '/Root';
  965.         $ASSetup::MetabaseConfig::LogObject->TRACE("Creating virtual directory: $szName") if $ASSetup::MetabaseConfig::LogObject;
  966.  
  967.     # Get the IIsWebServer Automation Object
  968.     $server = Win32::OLE->GetObject($serverPath);
  969.     if(!$server) {
  970.             $ASSetup::MetabaseConfig::LogObject->ERROR("Could not GetObject($serverPath) in MetabaseConfig::CreateVirDir: " . Win32::OLE->LastError()) if $ASSetup::MetabaseConfig::LogObject;
  971.             return;
  972.         }
  973.         
  974.  
  975.     # Create Our Virutual Directory or get it if it already exists
  976.     $virDir = $server->Create('IIsWebVirtualDir', $szName);
  977.     if( not UNIVERSAL::isa($virDir, 'Win32::OLE') )
  978.     {
  979.             $ASSetup::MetabaseConfig::LogObject->ERROR("Did not create IIsWebVirtualDir object in MetabaseConfig::CreateVirDir: " . Win32::OLE->LastError()) if $ASSetup::MetabaseConfig::LogObject;
  980.     $virDir = $server->GetObject('IIsWebVirtualDir', $szName);
  981.             if(!$virDir) {
  982.                 $ASSetup::MetabaseConfig::LogObject->ERROR("Could not GetObject($szName) in MetabaseConfig::CreateVirDir: " . Win32::OLE->LastError()) if $ASSetup::MetabaseConfig::LogObject;
  983.                 return;
  984.             }
  985.         
  986.         }
  987.  
  988.     $virDir->{Path}                  = $szPath;
  989.     $virDir->{AppFriendlyName}       = $szName;
  990.     $virDir->{EnableDirBrowsing}     = $bEnableDirBrowse;
  991.     $virDir->{AccessRead}            = $dwAccessPerm & MD_ACCESS_READ;
  992.     $virDir->{AccessWrite}           = $dwAccessPerm & MD_ACCESS_WRITE;
  993.     $virDir->{AccessExecute}         = $dwAccessPerm & MD_ACCESS_EXECUTE;
  994.     $virDir->{AccessScript}          = $dwAccessPerm & MD_ACCESS_SCRIPT;
  995.     $virDir->{AccessNoRemoteRead}    = $dwAccessPerm & MD_ACCESS_NO_REMOTE_READ;
  996.     $virDir->{AccessNoRemoteScript}  = $dwAccessPerm & MD_ACCESS_NO_REMOTE_SCRIPT;
  997.     $virDir->{AccessNoRemoteWrite}   = $dwAccessPerm & MD_ACCESS_NO_REMOTE_WRITE;
  998.     $virDir->{AccessNoRemoteExecute} = $dwAccessPerm & MD_ACCESS_NO_REMOTE_EXECUTE;
  999.  
  1000.     $virDir->AppCreate($bAppRoot);
  1001.     $virDir->SetInfo();
  1002. }
  1003.  
  1004. ###############################################################################
  1005. # DeleteVirDir( $dwServerID, $szVirDir );
  1006.  
  1007. sub DeleteVirDir
  1008. {
  1009.     my $dwServerID = $_[0];
  1010.     my $szVirDir   = $_[1];
  1011.     my $szPath     = '';
  1012.     my $server     = '';
  1013.  
  1014.     if($dwServerID eq "" || $szVirDir eq "")
  1015.     {
  1016. #            die "Incorrect Parameter to DeleteVirDir() ...\n";
  1017.     }
  1018.  
  1019.     # Create string that contains the Path to our Webserver's Root
  1020.     $szPath = 'IIS://localhost/W3SVC/' . $dwServerID . '/Root';
  1021.     $ASSetup::MetabaseConfig::LogObject->TRACE("Deleting virtual directory: $szPath") if $ASSetup::MetabaseConfig::LogObject;
  1022.     
  1023.         # Get the IIsWebServer Automation Object
  1024.     $server = Win32::OLE->GetObject($szPath);
  1025.     if(!$server) {
  1026.     $ASSetup::MetabaseConfig::LogObject->ERROR("Could not GetObject($szPath) in MetabaseConfig::DeleteVirDir: " . Win32::OLE->LastError()) if $ASSetup::MetabaseConfig::LogObject;
  1027.     return;
  1028.     }
  1029.         
  1030.     $server->Delete( "IIsWebVirtualDir", $szVirDir );
  1031.     $server->SetInfo();
  1032. }
  1033.  
  1034. ###############################################################################
  1035. #
  1036. ###############################################################################
  1037. package ASSetup::TR;
  1038.  
  1039. my %trans_table = ();
  1040.  
  1041. sub add_translation {
  1042.     $trans_table{$_[0]} = [ $_[1], $_[2] ];
  1043.     return 1;
  1044. }
  1045.  
  1046. sub reset_trans_table {
  1047.     %trans_table = ();
  1048.     return 1;
  1049. }
  1050.  
  1051. sub trans {
  1052.  
  1053.     my $file = shift;
  1054.     my @converted  = ();
  1055.  
  1056.     open(FH, "<$file") ||
  1057.         die "Could not open $file: $!\n";
  1058.  
  1059.     while(<FH>) {
  1060.  
  1061.         foreach my $key (keys %trans_table) {
  1062.         if($trans_table{$key}->[1]) {
  1063.             s/$key/$trans_table{$key}->[0]/eeg;
  1064.         } 
  1065.         else {
  1066.             s/$key/$trans_table{$key}->[0]/eg;
  1067.         }
  1068.         }
  1069.         push(@converted, $_);
  1070.     }
  1071.  
  1072.     close(FH);
  1073.  
  1074.     chmod(0777, $file);
  1075.     unlink($file);
  1076.  
  1077.     open(FH, ">$file") ||
  1078.         die "Could not open $file: $!\n";
  1079.  
  1080.     print(FH @converted);
  1081.  
  1082.     close(FH);
  1083.     return 1;
  1084. }
  1085.  
  1086. 1;
  1087.