home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / tk-config.pl < prev    next >
Encoding:
Perl Script  |  2004-05-21  |  20.7 KB  |  753 lines
  1. #!/Perl/bin/perl.exe
  2. use Tk;
  3. use CPAN;
  4. use strict;
  5. require Tk::Dialog;
  6. require Tk::ErrorDialog;
  7. use Win32::FileOp;
  8. use Tk::LabEntry;
  9. use Cwd;
  10. use FindBin qw($Bin);
  11. require File::Spec;
  12. use File::Find;
  13. use Win32::Process;
  14. use Win32;
  15. require Win32::Shortcut;
  16. require File::Spec;
  17. use File::Path;
  18. use Tk::Balloon;
  19. #use Pod::HTML;
  20. #use HTML::Parser;
  21. require LWP::Simple; import LWP::Simple qw(getstore);
  22.  
  23. use vars qw($html $cpan $perl_dir $apache_dir $start
  24.         $title $tmp $user $host $email);
  25.  
  26. my $error;
  27. my $shell = $ENV{ComSpec};
  28. my $get_nmake = 'get_nmake.bat';
  29. my $cpan_conf = 'cpanconf.bat';
  30. my $make_html = 'make_html.bat';
  31.  
  32. my ($pv, $av, $phpv, $mpv, $osv) = 
  33.   ('5.8.3', '2.0.49', '4.3.6', '1.99_13', '0.9.7d');
  34. my $apache = 'Apache2';
  35.  
  36. my $label = qq{Perl/$pv Apache/$av mod_perl/$mpv openSSL/$osv PHP/$phpv};
  37.  
  38. my $mw = MainWindow->new;
  39. $mw->title('Configure');
  40. $cpan =  1;
  41. $html =  1;
  42. $start =  1;
  43. my @path_ext = ();
  44. path_ext();
  45.  
  46. ($perl_dir = $Bin) =~ s!/bin!!;;
  47. @@apache2_directory@@
  48. $tmp = $ENV{TEMP} || $ENV{TMP};
  49. $tmp = Win32::GetShortPathName($tmp);
  50.  
  51. my $is_win95 = Win32::IsWin95();
  52. $user = ($is_win95 ? '' : Win32::LoginName()) || $ENV{USERNAME} 
  53.   || 'Administrator';
  54. $host = ($is_win95 ? '' : Win32::DomainName()) || $ENV{USERDOMAIN}
  55.   || 'localhost';
  56. (my $user_no_spaces = $user) =~ s! !!g;
  57. $email = $user_no_spaces . '@' . $host;
  58.  
  59. my $title = $mw->Label(-text => "Configure the Perl/$apache Win32 binary")
  60.   ->grid(-row => 0, -columnspan => 4);
  61.  
  62. my $b = $mw->Balloon();
  63.  
  64. my $perl_en = $mw->LabEntry(-textvariable => \$perl_dir,
  65.                 -label => 'Perl directory: ',
  66.                 -width => 22,
  67.                 -labelPack => [-side=>'left'])
  68.   ->grid(-padx => 10, -pady => 5, -row => 1, -column => 0,
  69.      -columnspan => 2, -sticky => 'e');
  70. help_msg($perl_en, 'Perl installation directory');
  71.  
  72. my $perl_br = $mw->Button(-text => 'Browse',
  73.               -command => [\&dir, 'perl'],
  74.              )
  75.   ->grid(-padx => 10, -pady => 5, -row => 1, -column => 2, 
  76.      -columnspan => 2, -sticky => 'w');
  77. help_msg($perl_br, 'Browse for the Perl installation directory');
  78.  
  79. my $apache_en = $mw->LabEntry(-textvariable => \$apache_dir,
  80.                   -label => "$apache directory: ",
  81.                   -width => 22,
  82.                   -labelPack => [-side=>'left'])
  83.   ->grid(-padx => 10, -pady => 5, -row => 2,  -column => 0,
  84.      -columnspan => 2, -sticky => 'e');
  85. help_msg($apache_en, "$apache installation directory");
  86.  
  87. my $apache_br = $mw->Button(-text => 'Browse',
  88.                 -command => [\&dir, 'apache'],
  89.                )
  90.   ->grid(-padx => 10, -row => 2, 
  91.      -columnspan => 2, -column => 2, -sticky => 'w');
  92. help_msg($apache_br, "Browse for the $apache installation directory");
  93.  
  94. my $user_en = $mw->LabEntry(-textvariable => \$user,
  95.                 -label => 'User name: ',
  96.                 -width => 20,
  97.                 -labelPack => [-side=>'left'])
  98.   ->grid(-padx => 5, -pady => 5, -row => 3, -column => 0,
  99.      -columnspan => 2, -sticky => 'e');
  100. help_msg($user_en, 'Your user name');
  101.  
  102. my $host_en = $mw->LabEntry(-textvariable => \$host,
  103.                 -label => 'Hostname: ',
  104.                 -width => 25,
  105.                 -labelPack => [-side=>'left'])
  106.   ->grid(-padx => 5, -pady => 5, -row => 4, -column => 0,
  107.      -columnspan => 2, -sticky => 'e');
  108. help_msg($host_en, 'Your host name');
  109.  
  110. my $email_en = $mw->LabEntry(-textvariable => \$email,
  111.                  -label => 'email: ',
  112.                  -width => 30,
  113.                  -labelPack => [-side=>'left'])
  114.   ->grid(-padx => 5, -pady => 5, -row => 5, -column => 0,
  115.      -columnspan => 2, -sticky => 'e');
  116. help_msg($email_en, 'Your email address');
  117.  
  118. my $cb_html = $mw->Checkbutton(-text => 'Build html docs',
  119.                    -variable => \$html,
  120.                    -onvalue => 1,
  121.                    -offvalue => 0,
  122.                   )
  123.   ->grid(-padx => 5, -pady => 5,
  124.      -row => 3, -column => 2, -sticky => 'w');
  125. help_msg($cb_html, 'Build and install available Perl html documentation');
  126.  
  127. my $cb_cpan = $mw->Checkbutton(-text => 'Configure CPAN.pm',
  128.                    -variable => \$cpan,
  129.                    -onvalue => 1,
  130.                    -offvalue => 0,
  131.                   )
  132.   ->grid(-padx => 5, -pady => 5,
  133.      -row => 4, -column => 2, -sticky => 'w');
  134. help_msg($cb_cpan, 'Configure the CPAN.pm module for building CPAN modules');
  135.  
  136. my $cb_start = $mw->Checkbutton(-text => 'Add Shortcuts',
  137.                 -variable => \$start,
  138.                 -onvalue => 1,
  139.                 -offvalue => 0,
  140.                    )
  141.   ->grid(-padx => 5, -pady => 5,
  142.      -row => 5, -column => 2, -sticky => 'w');
  143. help_msg($cb_start, 'Add shortcuts to the Start Menu');
  144.  
  145. my $help_syn = $mw->Button(-text => 'Help',
  146.                -command => [\&help],
  147.               )
  148.   ->grid(-padx => 5, -row => 2, -pady => 5,
  149.      -column => 3, -sticky => 'w');
  150. help_msg($help_syn, 'Display a brief help message');
  151.  
  152. my $brief = $mw->Button(-text => 'Readme',
  153.             -command => [\&tkreadme, '../install.txt'],
  154.                )
  155.   ->grid(-padx => 5, -row => 3, -pady => 5,
  156.      -column => 3, -sticky => 'w');
  157. help_msg($brief, 'Display the short README file');
  158.  
  159. my $configure = $mw->Button(-text => 'Configure',
  160.                 -command => [\&configure],
  161.                )
  162.   ->grid(-row => 7, -pady => 10,
  163.      -column => 1, -sticky => 'w');
  164. help_msg($configure, 'Start the configuration');
  165.  
  166. my $exit = $mw->Button(-text => 'Exit',
  167.                -command => [$mw => 'destroy'],
  168.               )
  169.   ->grid(-row => 7, -pady => 10,
  170.      -column => 2, -sticky => 'e');
  171. help_msg($exit, 'Quit Configure');
  172.  
  173. MainLoop;
  174.  
  175. sub configure {
  176.   $perl_dir = trim($perl_dir);
  177.   $perl_dir = Win32::GetShortPathName($perl_dir) if ($perl_dir =~ / /);
  178.   unless (-d $perl_dir) {
  179.     dialog_error('Perl configuration failed', 
  180.          qq{Cannot find "$perl_dir": $!.});
  181.     return;
  182.   }
  183.   unless (-d "$perl_dir/bin") {
  184.     dialog_error('Perl configuration failed',
  185.          qq{Please give the top-level Perl directory.});
  186.     return;
  187.   }
  188.   
  189.   $apache_dir = trim($apache_dir);
  190.   $apache_dir = Win32::GetShortPathName($apache_dir) if ($apache_dir =~ / /);
  191.   unless (-d $apache_dir) {
  192.     dialog_error('Apache configuration failed',
  193.          qq{Cannot find "$apache_dir": $!});
  194.     return;
  195.   }
  196.   unless (-d "$apache_dir/bin") {
  197.     dialog_error('Apache configuration failed',
  198.          qq{Please give the top-level $apache directory.});
  199.     return;
  200.   }
  201.   
  202.   $email = trim($email);
  203.   $host = trim($host);
  204.   $user = trim($user);
  205.   
  206.   configure_apache() or do {
  207.     dialog_error("$apache configuration failed",
  208.          "Failed to configure $apache.");
  209.     return;
  210.   };
  211.   
  212.   configure_perl() or do {
  213.     dialog_error('Perl configuration failed',
  214.          qq{Failed to configure Perl.});
  215.     return;
  216.   };
  217.   
  218.   unless ($perl_dir eq 'D:/Perl') {
  219.     configure_cgi() or do {
  220.       return unless dialog_proceed('Apache CGI configuration failed',
  221.                    qq{Failed to configure CGI.});
  222.     };
  223.   }
  224.   
  225.   if ($start) {
  226.     add_start() or do {
  227.       return unless dialog_proceed('Adding shortcuts failed', 
  228.                    qq{Failed to add shortcuts.});
  229.     };
  230.   }
  231.  
  232.   if ($html) {
  233.     install_html() or do {
  234.       return unless dialog_proceed('HTML build error', 
  235.                    qq{The HTML docs were not built.});
  236.     };
  237.   }
  238.   if ($cpan) {
  239.     configure_cpan() or do {
  240.       return unless dialog_proceed('CPAN config error',
  241.                    qq{The CPAN.pm module was not configured.});
  242.     };
  243.   }
  244.   configure_end();
  245. }
  246.  
  247. sub help {
  248.   my $message = <<"END";
  249.  
  250. Verify, and change if needed, the top-level Perl and $apache 
  251. installation directories (eg, D:\\Perl and D:\\$apache)
  252.  
  253. Verify your name, hostname, and email address.
  254.  
  255. Select whether or not to install the html documentation
  256. and to configure the CPAN.pm module. Also choose whether
  257. or not to add some shortcuts (documentation, and certain
  258. program utilities) to the Start Menu.
  259.  
  260. If the directories are not yet in their final locations,
  261. exit the configuration script, move the directories, and
  262. run this script again (in the Perl bin/ directory).
  263.  
  264. Versions:
  265. $label
  266.  
  267. END
  268.   
  269.   dialog_help('Help', $message);
  270. }
  271.  
  272. sub configure_apache {
  273.   for my $file (qw(httpd ssl perl)) {
  274.     my $conf = $apache_dir . '/conf/' . $file . '.conf';
  275.     my %subs = ("D:/$apache" => $apache_dir, 'D:/Temp' => $tmp,
  276.         '@@ServerAdmin@@' => $email, localhost => $host,
  277.         'D:/Perl' => $perl_dir);
  278.     edit($conf, \%subs) or return;
  279.   }
  280.   return 1 if ($apache eq 'Apache');
  281.   my $handler_dir = $perl_dir . '/site/lib/Apache2/Apache';
  282.   for my $file( 'MyHandler.pm', 'MyTTHandler.pm') {
  283.     my $handler = $handler_dir . '/' . $file;
  284.     my %subs = ("D:/$apache" => $apache_dir, 'D:/Temp' => $tmp);
  285.     edit($handler, \%subs) or return;
  286.   }
  287.   return 1;
  288. }
  289.  
  290. sub configure_perl {
  291.   my $dir = $perl_dir;
  292.   (my $windir = $dir) =~ s!/!\\!g;
  293.   (my $win2dir = $windir) =~ s!\\!\\\\!g;
  294.   my $ppm = $dir . '/site/lib/ppm.xml';
  295.   my %tmp = ('D:\Temp' => $tmp, 'D:\Perl' => $windir);
  296.   edit($ppm, \%tmp) or return;
  297.  
  298.   my $h = $dir . '/lib/CORE/config.h';
  299.   my %h = ('D:\\\\Perl' => $win2dir);
  300.   edit($h, \%h) or return;
  301.  
  302.   my $conf = $dir . '/lib/Config.pm';
  303.   my %subs = ('D:\Perl' => $windir, 
  304.           'randy\@theoryx5.uwinnipeg.ca' => $email,
  305.           'Randy Kobes' => $user);
  306.   my @progs = qw(awk grep tar gzip zip nmake);
  307.   my %progs;
  308.   foreach (@progs) {
  309.     $progs{$_} = 1 if which($_);
  310.   }
  311.   unless ($progs{nmake}) {
  312.     my $message = <<"END";
  313. I couldn\'t find "nmake" on your system. This program
  314. is needed to build modules from CPAN sources.
  315.   
  316. Do you want me to fetch and install nmake?.
  317. END
  318.  
  319.     if (dialog_yes_no('Get nmake?', $message)) {
  320.       if (fetch_nmake()) {
  321.     $progs{nmake} = 1;
  322.     dialog_help('Success', 'Installation of "nmake" succeeded');
  323.       }
  324.       else {
  325.     dialog_error('nmake installation failed', 
  326.              qq{Could not get or install "nmake".});
  327.       }
  328.     }
  329.   }
  330.   foreach (@progs) {
  331.     if ($_ eq 'nmake') {
  332.       $subs{"make='nmake'"} = $progs{nmake} ? 
  333.     "make='nmake'" : "make=''";
  334.     }
  335.     else {
  336.       $subs{"$_='$_'"} = $progs{$_} ? 
  337.     "$_='$_'" : "$_=''";
  338.     }
  339.   }
  340.   return edit($conf, \%subs);
  341. }
  342.  
  343. sub fetch_nmake {
  344.   return launch($get_nmake);
  345. }
  346.  
  347. sub configure_cgi {
  348.   my $cgi = $apache_dir . '/cgi-bin';
  349.   my $perl_bin = $perl_dir . '/bin/perl.exe';
  350.   my @files = ();
  351.   finddepth(sub {next unless $File::Find::name =~ m!\.cgi$!;
  352.          push @files, $File::Find::name;}, $cgi);
  353.   my %sub = ('D:/Perl/bin/perl' => $perl_bin);
  354.   foreach my $file (@files) {
  355.     edit($file, \%sub) or return;
  356.   }
  357.   return 1;
  358. }
  359.  
  360. sub add_start {
  361.   (my $perl = $perl_dir) =~ s!/!\\!g;
  362.   (my $apache_start = $apache_dir) =~ s!/!\\!g;
  363.   
  364.   my $start = 'Start Menu/Programs';
  365.   
  366.   my $user_profile = $ENV{USERPROFILE} ?
  367.     $ENV{USERPROFILE} : 'C:\Documents and Settings';
  368.   
  369.   unless (-d $user_profile) {
  370.     $error = qq{Could not determine your profile directory.};
  371.     return;
  372.   }
  373.   
  374.   unless (-d "$user_profile/$start") {
  375.     $error = qq{Could not determine your Programs directory.};
  376.     return;
  377.   }
  378.  
  379.   my $group = File::Spec->catdir($user_profile, $start, 
  380.                  "Perl $apache binary");
  381.  
  382.   if (-d $group) {
  383.     rmtree($group) or do {
  384.       $error = qq{Cannot rmtree "$group": $!};
  385.       return;
  386.     };
  387.   }
  388.  
  389.   mkdir $group or do {
  390.     $error = qq{Cannot mkdir "$group": $!};
  391.     return;
  392.   };
  393.  
  394.   mkdir "$group/Documentation"  or do {
  395.     $error = qq{Cannot mkdir "$group/Documentation": $!};
  396.     return;
  397.   };
  398.   
  399.   my $manual = $apache eq 'Apache2' ? 'manual' : 'htdocs\manual';
  400.   my $ssl = $apache eq 'Apache2' ? 'manual\ssl' :
  401.     'htdocs\manual\mod\mod_ssl';
  402.   my %docs = (
  403.           'mod_perl' => 
  404.           File::Spec->catfile($apache_start, 
  405.                   'modperl\index.html'),
  406.           'Apache-ASP' => 
  407.           File::Spec->catfile($apache_start, 
  408.                   'modperl\asp\index.html'),
  409.           'HTML-Mason' => 
  410.           File::Spec->catfile($apache_start, 
  411.                   'modperl\mason\index.html'),
  412.           'Template-Toolkit' 
  413.           => File::Spec->catfile($apache_start, 
  414.                      'modperl\tt\index.html'),
  415.           'Perl' => File::Spec->catfile($perl, 
  416.                         'html\index.html'),
  417.          );
  418.   
  419.   my $apache_group = File::Spec->catdir($group, $apache);
  420.   mkdir $apache_group  or do {
  421.     $error = qq{Cannot mkdir "$apache_group": $!};
  422.     return;
  423.   };
  424.  
  425.   my $link = new Win32::Shortcut();
  426.  
  427.   for (keys %docs) {
  428.     $link->Path($docs{$_});
  429.     $link->Arguments("");
  430.     $link->WorkingDirectory("");
  431.     $link->Description($_);
  432.     $link->Save("$group\\Documentation\\$_.lnk");
  433.   }
  434.   
  435.  PERL: {
  436.     $link->Path("$perl\\bin\\ppm.bat");
  437.     $link->Arguments("");
  438.     $link->WorkingDirectory("$perl\\bin");
  439.     $link->Description('Perl Package Manager');
  440.     $link->ShowCmd(SW_SHOWNORMAL);
  441.     $link->Save("$group\\PPM.lnk");
  442.     $link->Path("$perl\\bin\\tk-ppm.bat");
  443.     $link->Arguments("");
  444.     $link->WorkingDirectory("$perl\\bin");
  445.     $link->Description('tk-ppm');
  446.     $link->ShowCmd(SW_SHOWNORMAL);
  447.     $link->Save("$group\\tk-ppm.lnk");
  448.   }
  449.   
  450.  APACHE: {
  451.     
  452.     $link->Path("$apache_start\\conf\\httpd.conf");
  453.     $link->Arguments("");
  454.     $link->WorkingDirectory("$apache_start\\conf");
  455.     $link->Description('Edit httpd.conf');
  456.     $link->Save("$apache_group\\Edit httpd.conf.lnk");
  457.     
  458.     if ($apache eq 'Apache2') {
  459.       $link->Path("$apache_start\\bin\\MyApache.bat");
  460.     }
  461.     else {
  462.           $link->Path("$apache_start\\MyApache.bat");
  463.     }
  464.     my @mp_args = ('-w', '-d', qq{"$apache_start"}, 
  465.            '-f', qq{"$apache_start\\conf\\httpd.conf"});
  466.     my $wd = $apache eq 'Apache2' ?
  467.       File::Spec->catdir($apache_start, 'bin') : $apache_start;
  468.     my $apache_exe = File::Spec->catfile($wd, 'Apache.exe');
  469.     $link->ShowCmd(SW_SHOWNORMAL);
  470.     $link->WorkingDirectory($wd);
  471.     
  472.     my $args = join ' ', @mp_args, '-D', 'SSL', '-t';
  473.     $link->Arguments($args);
  474.     $link->Description("Test syntax of $apache httpd.conf");
  475.     $link->Save("$apache_group\\Test $apache configuration.lnk");
  476.     
  477.   }
  478.   if (-e "$apache_group\\Test $apache configuration.lnk") {
  479.     my $message = <<"END";
  480. Documentation and some program links have been added in the 
  481. "Perl $apache binary" Programs group of your Start Menu.
  482. END
  483.   dialog_help('Shortcuts added', $message);
  484.     return 1;
  485.   }
  486.   else {
  487.     $error = qq{Could not make shortcuts in $group};
  488.     return;
  489.   }
  490. }
  491.  
  492. sub edit {
  493.   my ($file, $subs) = @_;
  494.   my $copy = $file . '.old';
  495.   unless (-e $copy) {
  496.     rename $file, $copy or do {
  497.       $error = qq{Cannot rename "$file" to "$copy": $!.};
  498.       return;
  499.     };
  500.   }
  501.   my $pat = join '|', keys %$subs;
  502.   $pat = "($pat)";
  503.   $pat =~ s!D:\\\\Perl!D:\\\\\\\\Perl!;
  504.   $pat =~ s!D:\\Perl!D:\\\\Perl!;
  505.   $pat =~ s!D:\\Temp!D:\\\\Temp!;
  506.   open(OLD, $copy) or do {
  507.     $error = qq{Cannot open "$copy": $!.};
  508.     return;
  509.   };
  510.   open(NEW, ">$file")  or do {
  511.     $error = qq{Cannot open "$file": $!.};
  512.     return;
  513.   };
  514.   while (<OLD>) {
  515.     s/$pat/$subs->{$1}/g;
  516.     print NEW $_;
  517.   }
  518.   close OLD;
  519.   close NEW;
  520.   return 1;
  521. }
  522.  
  523. sub path_ext {
  524.   if ($ENV{PATHEXT}) {
  525.     push @path_ext, split ';', $ENV{PATHEXT};
  526.     for my $ext (@path_ext) {
  527.       $ext =~ s/^\.*(.+)$/$1/;
  528.     }
  529.   }
  530.   else {
  531.     #Win9X: doesn't have PATHEXT
  532.     push @path_ext, qw(com exe bat);
  533.   }
  534. }
  535.  
  536. sub which {
  537.   my $program = shift;
  538.   return unless $program;
  539.   for my $base (map { File::Spec->catfile($_, $program) } File::Spec->path()) {
  540.     return $base if -x $base;
  541.     
  542.     for my $ext (@path_ext) {
  543.       return "$base.$ext" if -x "$base.$ext";
  544.     }
  545.   }
  546. }
  547.  
  548. sub install_html {
  549.   my $message = <<"END";
  550. Proceed to build html documents? 
  551.   (this may take a while).
  552.  
  553. END
  554.   return unless dialog_yes_no('Build html docs?', $message);
  555.  
  556.   my $perl = $perl_dir . '/bin/perl';
  557.   return launch($make_html);
  558.  
  559. #  my $podroot = $perl_dir;
  560. #  my $perl = $podroot . '/bin/perl';
  561. #  my @pods = qw(lib site);
  562. #  my $htmldir = $podroot . '/html';
  563. #  my $htmlroot = "file://$htmldir";
  564. #  my $podpath = join ':', @pods;
  565. #  my $libpod = 'perlfunc:perlguts:perlvar:perlrun:perlop';
  566. #  my @args = ($perl,
  567. #         'myinstallhtml',
  568. #         "--podroot=$podroot",
  569. #         "--htmldir=$htmldir",
  570. #         "--htmlroot=$htmlroot",
  571. #         "--podpath=$podpath",
  572. #         "--libpod=$libpod",
  573. #         qq{--backlink="Up to Top"},
  574. #         qq{--css="$htmlroot/style.css"},
  575. #         "--verbose",
  576. #         '--recurse');
  577. ##  system(@args);
  578.   
  579. #  my $p = HTML::Parser->new(api_version => 3,
  580. #               start_h => [\&title_handler, 'self'],
  581. #               report_tags => ['title'],
  582. #              );
  583. #  
  584. #  open(INDEX, ">$htmldir/index.html") or do {
  585. #    $error = qq{Cannot open "$htmldir/index.html": $!};
  586. #    return;
  587. #  };
  588. #  print INDEX <<"END";
  589. #<HTML>
  590. #<HEAD><TITLE>Perl Documentation</TITLE></HEAD>
  591. #<BODY>
  592. #END
  593. #  
  594. #  foreach my $pod (@pods) {
  595. #    my $root = $htmldir . '/' . $pod;
  596. #    my $head = ($pod eq 'lib') ?
  597. #      'Core Documentation' : 'Contributed Documentation'; 
  598. #    print INDEX qq{<H3>$head</H3>};
  599. #    my @files = ();
  600. #    finddepth(sub {push @files, $File::Find::name;}, $root);
  601. #    
  602. #    foreach my $file(sort @files) {
  603. #      $p->parse_file($file) || next;
  604. #      next if $title =~ m!$podroot!;
  605. #      print INDEX qq{<A HREF="file://$file">$title</A><BR>\n};
  606. #    }
  607. #    
  608. #  }
  609. #  print INDEX qq{</BODY></HTML>};
  610. #  close INDEX;
  611. #  return 1;
  612. }
  613.  
  614. sub title_handler {
  615.   my $self = shift;
  616.   $self->handler(text => sub { $title = "@_" }, "dtext");
  617.   $self->handler(end  => "eof", "self");
  618. }
  619.  
  620. sub configure_cpan {
  621.   my $message = <<"END";
  622. Proceed with configuring CPAN.pm? 
  623.  (used to install CPAN modules for which no ppm packages exist).
  624.  
  625. END
  626.   return unless dialog_yes_no('Configure CPAN.pm?', $message);
  627.   launch($cpan_conf) or return;
  628.   return 1;
  629. }
  630.  
  631. sub help_msg {
  632.   my ($widget, $msg) = @_;
  633. #  $widget->bind('<Enter>', [sub {$message = $_[1]; }, $msg]);
  634. #  $widget->bind('<Leave>', [sub {$message = ''; }]);
  635.   $b->attach($widget, -balloonmsg => $msg);
  636. }
  637.  
  638. sub tkreadme {
  639.   my $file = shift;
  640.   my $tl = $mw->Toplevel;
  641.   $tl->title('README');
  642.   my $scroll = $tl->Scrollbar();
  643.   my $readme = $tl->Text(-yscrollcommand => ['set' => $scroll]);
  644.   open(README, $file) or do {
  645.     dialog_error('File not found', qq{Cannot find "$file"});
  646.     return;
  647.   };
  648.   $readme->insert('end', $_) while (<README>);
  649.   close(README);
  650.   $scroll->configure(-command => ['yview' => $readme]);
  651.   $scroll->pack(-side => 'left', -fill => 'y');
  652.   $readme->pack(-side => 'top', -fill => 'y');
  653.   my $quit = $tl->Button(-text => 'Close',
  654.              -command => sub {$tl->destroy },
  655.             )->pack(-side => 'top');
  656. }
  657.  
  658. sub dialog_error {
  659.   my ($title, $msg) = @_;
  660.   $msg .= "\n\n$error" if $error;
  661.   Win32::MsgBox($msg, MB_ICONEXCLAMATION, $title);
  662.   undef $error;
  663. }
  664.  
  665. sub dialog_proceed {
  666.   my ($title, $msg) = @_;
  667.   $msg .= "\n\n$error" if $error;
  668.   $msg .= "\n\nProceed with configuration?";
  669.   my $ans = Win32::MsgBox($msg, 4, $title);
  670.   undef $error;
  671.   return ($ans == 6) ? 1 : 0;
  672. }
  673.  
  674. sub dialog_help {
  675.   my ($title, $msg) = @_;
  676.   Win32::MsgBox($msg, MB_ICONINFORMATION, $title);
  677. }
  678.  
  679. sub dialog_yes_no {
  680.   my ($title, $msg) = @_;
  681.   my $ans = Win32::MsgBox($msg, 4, $title);
  682.   return ($ans == 6) ? 1 : 0;
  683. }
  684.  
  685. sub dir {
  686.   my $type = shift;
  687.   my $dir;
  688.    if ($type eq 'perl') {
  689.      if ($dir = BrowseForFolder('Perl installation directory', 
  690.                 CSIDL_DRIVES)) {
  691.        ($perl_dir = $dir) =~ s!\\!/!g;
  692.      }
  693.    }
  694.   else {
  695.     if ($dir = BrowseForFolder('Apache installation directory', 
  696.                    CSIDL_DRIVES)) {
  697.       ($apache_dir = $dir) =~ s!\\!/!g;
  698.     }
  699.   }
  700. }
  701.  
  702. sub trim {
  703.   local $_ = shift;
  704.   s/^\s+//;
  705.   s/\s+$//;
  706.   return $_;
  707. }
  708.  
  709. sub launch {
  710.   my $cmd = shift;
  711.   if (ref($cmd) eq 'ARRAY') {
  712.     $cmd = join ' ', @{$cmd};    
  713.   }
  714.   my $ProcessObj;
  715.   $mw->withdraw;
  716.   Win32::Process::Create($ProcessObj,
  717.              "$shell",
  718.              "$shell /c $cmd",
  719.              0,
  720.              NORMAL_PRIORITY_CLASS | CREATE_NEW_CONSOLE,
  721.              ".")
  722.       or do {
  723.     $error = Win32::FormatMessage(Win32::GetLastError());
  724.     $mw->deiconify;
  725.     $mw->raise;
  726.     return;
  727.       };
  728.   $ProcessObj->Wait(INFINITE);
  729.   $mw->deiconify;
  730.   $mw->raise;
  731.   return 1;
  732. }
  733.  
  734. sub configure_end {
  735.   my $apbin = $apache_dir;
  736.   $apbin .= '/bin' if $apache eq 'Apache2';
  737.   my $end = <<"END";
  738.  
  739. As described in install.txt under $perl_dir, 
  740. please check the settings in
  741.    $apache_dir/conf/httpd.conf
  742.    $apache_dir/cgi-bin/*.cgi
  743.    $perl_dir/lib/Config.pm
  744.    $perl_dir/lib/CPAN/Config.pm
  745.    $perl_dir/site/lib/ppm.xml
  746. and make sure "$perl_dir/bin" and "$apbin"
  747. are included in your PATH environment variable.
  748.  
  749. END
  750.   dialog_help('Configuration complete', $end);
  751.   $mw->destroy;
  752. }
  753.