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