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