1# Vend::MakeCat - Routines for Interchange catalog configurator 2# 3# $Id: MakeCat.pm,v 2.17 2007-08-09 13:40:53 pajamian Exp $ 4# 5# Copyright (C) 2002-2007 Interchange Development Group 6# Copyright (C) 1996-2002 Red Hat, Inc. 7# 8# This program was originally based on Vend 0.2 and 0.3 9# Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com> 10# 11# This program is free software; you can redistribute it and/or modify 12# it under the terms of the GNU General Public License as published by 13# the Free Software Foundation; either version 2 of the License, or 14# (at your option) any later version. 15# 16# This program is distributed in the hope that it will be useful, 17# but WITHOUT ANY WARRANTY; without even the implied warranty of 18# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19# GNU General Public License for more details. 20# 21# You should have received a copy of the GNU General Public 22# License along with this program; if not, write to the Free 23# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, 24# MA 02110-1301 USA. 25 26package Vend::MakeCat; 27 28use Cwd; 29use File::Find; 30use File::Copy; 31use File::Basename; 32use Sys::Hostname; 33use Vend::Util; 34require Safe; 35$Safe = new Safe; 36 37require Exporter; 38@ISA = qw(Exporter); 39@EXPORT = qw( 40 41%Conf 42%Content 43%Ever 44%History 45%IfRoot 46%Commandline 47%Postprocess 48%Prefix 49%Window 50$Force 51$Safe 52 53add_catalog 54addhistory 55applicable_directive 56can_do_suid 57check_root_execute 58compare_file 59conf_parse_http 60copy_current_to_dir 61copy_dir 62description 63debug 64directory_process 65do_msg 66error_message 67find_inet_info 68findexe 69findfiles 70get_id 71get_ids 72get_rename 73history 74inet_host 75inet_port 76install_file 77label 78prefix 79pretty 80prompt 81read_additional 82readconfig 83sethistory 84strip_na 85strip_trailing_slash 86substitute 87sum_it 88unique_ary 89validate 90 91); 92 93 94use strict; 95 96use vars qw($Safe $Force $Error $History $VERSION); 97 98$Safe->share(qw/%Conf %Ever &debug/); 99 100use vars qw/ 101 %Alias 102 %Conf 103 %Content 104 %Commandline 105 %Ever 106 %History 107 %IfRoot 108 %Postprocess 109 %Special_sub 110 %Prefix 111 %Window 112/; 113 114$VERSION = substr(q$Revision: 2.17 $, 10); 115 116$Force = 0; 117$History = 0; 118 119%Alias = ( 120 serverconf => { 121 linux => '/etc/httpd/conf/httpd.conf', 122 }, 123); 124 125my %Watch = qw/ 126 cfg_extramysql 1 127 /; 128 129my %Pretty = ( 130 qw/ 131 aliases Aliases 132 basedir BaseDir 133 catroot CatRoot 134 catuser CatUser 135 cgibase CgiBase 136 cgidir CgiDir 137 cgiurl CgiUrl 138 demotype DemoType 139 documentroot DocumentRoot 140 imagedir ImageDir 141 imageurl ImageUrl 142 interchangegroup InterchangeGroup 143 interchangeuser InterchangeUser 144 mailorderto MailOrderTo 145 samplehtml SampleHtml 146 sampleurl SampleUrl 147 serverconf ServerConf 148 servername ServerName 149 sharedir ShareDir 150 shareurl ShareUrl 151 vendroot VendRoot 152/, 153 linkmode => 'Link mode', 154 155); 156 157my %Label = ( 158 add_catalog => 'Add catalog to interchange.cfg', 159 aliases => 'Link aliases', 160 basedir => 'Base directory for catalogs', 161 catroot => 'Catalog directory', 162 catuser => 'Catalog user', 163 catalogname => 'Catalog name', 164 cgibase => 'CGI base URL', 165 cgidir => 'CGI Directory', 166 cgiurl => 'URL call for catalog', 167 demotype => 'Catalog skeleton', 168 documentroot => 'Document Root', 169 imagedir => 'Image directory', 170 imageurl => 'Image base URL', 171 interchangeuser => 'Interchange daemon username', 172 interchangegroup => 'Interchange daemon groupname', 173 linkhost => 'Link host', 174 linkmode => 'Link mode', 175 linkport => 'Link port', 176 mailorderto => 'Email address for orders', 177 permtype => 'Permission Type', 178 run_catalog => 'Add catalog to running server', 179 samplehtml => 'Catalog HTML base directory', 180 servconflist => 'Server config files found', 181 serverconf => 'Server config file', 182 serverlist => 'Servers in httpd.conf', 183 servername => 'Server name', 184 sharedir => 'Share Directory', 185 shareurl => 'Share URL', 186 win_addcatalog => 'Add catalog to Interchange', 187 win_catinfo => 'Catalog Initialization Information', 188 win_greeting => 'Make an Interchange Catalog', 189 win_servername => 'HTTP ServerName', 190 win_server => 'HTTP Server Information', 191 win_serverconf => 'HTTP Server Configuration File', 192 win_linkinfo => 'Link Program Information', 193 win_urls => 'URL and Directory Information', 194); 195 196my %Desc = ( 197 add_catalog => <<EOF, 198# To make the catalog active, you must add it to the 199# interchange.cfg file. If you don't select this, then you will 200# have to manually add it later. 201EOF 202 203 aliases => <<EOF, 204# 205# Additional URL locations for the CGI program, as with CgiUrl. 206# This is used when calling the catalog from more than one place, 207# perhaps because your secure server is not the same name as the 208# non-secure one. 209# 210# http://www.secure.domain/secure-bin/prog 211# ^^^^^^^^^^^^^^^^ 212# 213# We set it to the name of the catalog by default to enable the 214# internal HTTP server. 215# 216EOF 217 218 basedir => <<EOF, 219# 220# DIRECTORY where the Interchange catalog directories will go. 221# These are the catalog files, such as the ASCII database source, 222# Interchange page files, and catalog.cfg file. Catalogs will be 223# an individual subdirectory of this directory. 224# 225EOF 226 227 catalogname => <<EOF, 228# Select a short, mnemonic name for the catalog. This will be 229# used to set the defaults for naming the catalog, executable, 230# and directory, so you will have to type in this name 231# frequently. 232# 233# NOTE: This will be the name of 'vlink' or 'tlink', the link CGI 234# program. Depending on your CGI setup, it may also have 235# the extension .cgi added. 236# 237# Only the characters [-a-zA-Z0-9_] are allowed, and it is 238# strongly suggested that the catalog name be all lower case. 239# 240# If you are doing the demo for the first time, you might use 241# "standard". 242EOF 243 244 catroot => <<EOF, 245# Where the Interchange files for this catalog will go, pages, 246# products, config and all. This should not be in HTML document 247# space! Usually a 'catalogs' directory below your home directory 248# works well. Remember, you will want a test catalog and an 249# online catalog. 250EOF 251 252 catuser => <<EOF, 253# 254# The user name the catalog will be owned by. 255# 256EOF 257 258 cgibase => <<EOF, 259# 260# The URL-style location of the normal CGI directory. 261# Only used to set the default for the CgiUrl setting. 262# 263# http://www.virtual.com/cgi-bin/prog 264# ^^^^^^^^ 265# 266# If you have no CGI-bin directory, (your CGI programs end 267# in .cgi), leave this blank. 268# 269EOF 270 271 cgidir => <<EOF, 272# The location of the normal CGI directory. This is a 273# file path, not a script alias. 274# 275# If all of your CGI programs must end in .cgi, this is 276# should be the same as your HTML directory. 277# 278EOF 279 280 cgiurl => <<EOF, 281# The URL location of the CGI program, without the http:// 282# or server name. 283# 284# http://www.virtual.com/cgi-bin/prog 285# ^^^^^^^^^^^^^ 286# 287# http://www.virtual.com/program.cgi 288# ^^^^^^^^^^^^ 289# 290EOF 291 292 demotype => <<EOF, 293# The type of demo catalog to use. The standard one distributed is: 294# 295# standard 296# 297# If you have defined your own custom template catalog, 298# you can enter its name. 299# 300# If you are new to Interchange, use "standard" to start with. 301EOF 302 303 documentroot => <<EOF, 304# The base directory for HTML for this (possibly virtual) domain. 305# This is a directory path name, not a URL -- it is your HTML 306# directory. 307# 308EOF 309 310 imagedir => <<EOF, 311# Where the image files should be copied. A directory path 312# name, not a URL. 313# 314EOF 315 316 imageurl => <<EOF, 317# The URL base for the sample images. Sets the ImageDir 318# directive in the catalog configuration file. This is a URL 319# fragment, not a directory or file name. 320# 321# <IMG SRC="/standard/images/icon.gif"> 322# ^^^^^^^^^^^^^^^^ 323# 324EOF 325 326 interchangegroup => <<EOF, 327# The group name the server-owned files should be set to. This is 328# only important if Interchange catalogs will be owned by 329# multiple users and the group to be used is not the default for 330# the catalog user. 331# 332# Normally this is left blank. 333EOF 334 335 interchangeuser => <<EOF, 336# The user name the Interchange server runs under on this 337# machine. This should not be the same as the user that runs the 338# HTTP server (i.e. NOT nobody). 339EOF 340 341 linkhost => <<EOF, 342# If you are using INET mode, you need to set the host the link 343# CGI will talk to. 344# 345# If Interchange is running on the same server as your web 346# server, this should be "localhost" or "127.0.0.1". If the web 347# server is on a different machine, it is the IP address of the 348# machine Interchange is running on. 349EOF 350 351 linkmode => <<EOF, 352# Interchange can use either UNIX- or internet-domain sockets. 353# Most ISPs would prefer UNIX mode, and it is more secure. 354# 355# If you already have a program there, or use mod_interchange, 356# select NONE. You will then need to copy the program by hand or 357# otherwise ensure its presence. 358EOF 359 360 linkport => <<EOF, 361# If you are using INET mode, you need to set the port the 362# link CGI will talk to. The IANA standard for Interchange is 363# port 7786. 364EOF 365 366 mailorderto => <<EOF, 367# The email address where orders for this catalog should go. To 368# have a secure catalog, either this should be a local user name 369# and not go over the Internet -- or use the PGP option. 370# 371EOF 372 373 permtype => <<EOF, 374# The type of permission structure for multiple user catalogs. 375# 376# Select: 377# M for each user in own group (with interchange user in group) 378# G for all users in group of interchange user 379# U for all catalogs owned by interchange user 380# (should be catuser as well) 381# 382# M is recommended, G works for most installations. 383EOF 384 385 run_catalog => <<EOF, 386# You can add this catalog to the running Interchange server. You 387# may not want to do this if you are using a SQL database, as you 388# will not be able to monitor the database creation activity. 389# 390# If you don't do it, then you can restart Interchange to 391# activate the new catalog. 392EOF 393 394 samplehtml => <<EOF, 395# Where the sample HTML files (not Interchange pages) should be 396# installed. There is a difference. Usually a subdirectory of 397# your HTML directory. 398# 399EOF 400 401 sampleurl => <<EOF, 402# Our guess as to the URL to run this catalog, used for the 403# client-pull screens and an informational message, not prompted for. 404# 405EOF 406 407 servconflist => <<EOF, 408# A list of server configuration files automatically found. 409# When you use history to change this, it will be reflected 410# in the next field to save you entering the file name. 411# 412EOF 413 414 serverconf => <<EOF, 415# The server configuration file, if you are running 416# Apache or NCSA. Often: 417# /etc/httpd/conf/httpd.conf 418# /usr/local/apache/conf/httpd.conf 419# /usr/local/etc/httpd/conf/httpd.conf 420# 421EOF 422 423 servername => <<EOF, 424# The server name, something like: www.company.com 425# www.company.com:8000 426# www.company.com/~yourname 427# 428EOF 429 430 sharedir => <<EOF, 431# This is a directory path name (not a URL) where the administration user 432# interface images from share/ should be copied to. These will normally be 433# shared by all catalogs. Often this is the same as your DocumentRoot. 434# 435EOF 436 437 shareurl => <<EOF, 438# The URL base for the administration user interface images. 439# This is a URL fragment, not an entire URL. 440# 441# <IMG SRC="/interchange-5/en_US/bg.gif"> 442# (leave blank) 443# 444# <IMG SRC="/~yourname/interchange-5/en_US/bg.gif"> 445# ^^^^^^^^^^ 446# 447EOF 448 449 vendroot => <<EOF, 450# The directory where the Interchange software is installed. 451# 452EOF 453 454 win_addcatalog => <<EOF, 455# You should add the catalog callout to interchange.cfg, and 456# optionally can add it into the running server. 457EOF 458 459 win_catinfo => <<EOF, 460# We need to set base template type and directory for your catalog. 461EOF 462 463 win_greeting => <<EOF, 464# Welcome to Interchange! 465# 466# You can now configure a working catalog. 467# 468# You can exit by selecting the "Cancel" button below, but your 469# catalog will not be built until you complete the configuration. 470EOF 471 472 win_linkinfo => <<EOF, 473# We need to get information necessary for compiling the link 474# program(s). 475EOF 476 477 win_server => <<EOF, 478# We need to know some basic HTTP Server configuration information. 479EOF 480 481 win_serverconf => <<EOF, 482# If you are using Apache or another HTTP server with the same 483# type of configuration file, we can read it and set some 484# defaults based on the server name you are using. 485EOF 486 487 win_servername => <<EOF, 488# Since you are running Apache, we can give you a choice of the 489# server names defined in the httpd.conf file you selected. This 490# will be used to pre-set items like DocumentRoot, ScriptAlias 491# (cgi-bin), etc. 492# 493# If you don't see your server, pick the empty option and go to 494# the next screen. 495EOF 496 497 win_urls => <<EOF, 498# We need to set the HTML, image, and executable paths for your 499# catalog. 500EOF 501 502); 503 504my %Validate = ( 505 demotype => <<EOF, 506The demotype skeleton directory must exist. In addition, if you 507are root the files must be owned by root and not be group- 508or world-writable. 509EOF 510); 511 512my %Build_error = ( 513 demotype => <<EOF, 514There were errors in copying the demo files. Cannot 515continue. Check to see if permissions are correct. 516EOF 517 518); 519 520my $Wname = 'content00'; 521 522sub readconfig { 523 my ($file, $ref) = @_; 524 return undef unless $file; 525 return undef unless -f $file; 526 $ref = {} unless ref $ref; 527 open (INICONF, "< $file") 528 or die "open $file: $!\n"; 529 local($/); 530 my $data = <INICONF>; 531 close INICONF; 532 my $novirt; 533 534 my %virtual; 535 536 $data =~ s/^\s*#.*//mg; 537 $data =~ m{(\[<)} 538 or $novirt = 1; 539 my $first = $1; 540 if($first eq '<') { 541 $data =~ s! 542 <catalog\s+ 543 544 ([^>\n]+) 545 \s*>\s+ 546 ([\000-\377]*?) 547 </catalog>! 548 $virtual{$1} = $2; ''!xieg; 549 550 $virtual{'_base'} = $data; 551 } 552 else { 553 my %recognize = ( base => '_base' ); 554 my @lines = grep /\S/, split /\n/, $data; 555 my $handle; 556 for(@lines) { 557 if(/^\[(.*?)\]\s*$/) { 558 my $hh = $1; 559 if($hh =~ /^catalog\s+(\S+)/) { 560 $handle = $1; 561 } 562 elsif($recognize{$hh}) { 563 $handle = $recognize{$hh}; 564 } 565 else { 566 undef $handle; 567 } 568 $virtual{$handle} = '' if ! $virtual{$handle}; 569 next; 570 } 571 next unless $handle; 572 next unless /\S/; 573 $virtual{$handle} .= $_; 574 } 575 } 576 577 my $out = {}; 578 foreach my $hk (keys %virtual) { 579 my $ref = $out->{$hk} = {}; 580 my @lines = grep /\S/, split /\n/, $virtual{$hk}; 581 for(@lines) { 582 s/^\s+//; 583 s/\s+$//; 584 my ($k, $v) = split /\s*=\s*/, $_, 2; 585 $ref->{$k} = $v; 586 } 587 } 588 return $out; 589} 590 591sub read_additional { 592 my ($file) = @_; 593 594 if (! $file) { 595 $file = "$Conf{vendroot}/$Conf{demotype}/config/additional_fields"; 596 return undef unless -f $file; 597 } 598 599 my $help = $file; 600 $help =~ s/_fields$/_help/ or undef $help; 601 my $data; 602 603 SPLIT: { 604 local ($/); 605 open ADDLFIELDS, "< $file" 606 or return undef; 607 $data = <ADDLFIELDS>; 608 close ADDLFIELDS; 609 } 610 611 HELP: { 612 local($/) = ""; 613 last HELP unless open ADDLHELP, "< $help"; 614 while(<ADDLHELP>) { 615 s/^[.\t ]+$//mg; 616 my ($k, $v) = split /\n/, $_, 2; 617 $Desc{lc $k} = $v; 618 } 619 close ADDLHELP; 620 } 621 622 my @chunks; 623 if($data =~ /^\s*</) { 624 @chunks = read_common_config($data); 625 return read_additional_new(@chunks); 626 } 627 else { 628 @chunks = split /\n\n+/, $data; 629 return read_additional_old(@chunks); 630 } 631} 632 633sub read_additional_old { 634 my (@chunks) = @_; 635 636 my @addl_windows; 637 my %label; 638 639 my $winref; 640 641 for(@chunks) { 642 my $noprompt = ''; 643 my $grp; 644 my $realgrp; 645 my $wid; 646 my $cref = {}; 647 s/\s+$//; 648 my ($var, $prompt, $default) = split /\n/, $_, 3; 649 650 ($var, $realgrp, $wid) = split /\t/, $var; 651 652 $cref->{widget} = $wid if $wid; 653 654 my $label; 655 ($prompt, $label) = split /\t/, $prompt, 2; 656 657 my $subcode; 658 my $mainparam; 659 660 if($var =~ s/{\s*([A-Z0-9]+)(\s*\S.*?)?\s*}\s*//) { 661 $mainparam = lc $1; 662 my $test = $2; 663 $test =~ s/'?__MVC_([A-Z0-9]+)__'?/\$Conf{\L$1}/g; 664 $subcode = <<EOF; 665sub { 666 my \$status; 667 if(\$Conf{$mainparam} $test) { 668 \$status = 1; 669 } 670 else { 671 \$status = 0; 672 } 673 return \$status; 674} 675EOF 676 677 my $sub = eval $subcode; 678 if($@) { 679 undef $sub; 680 } 681 $cref->{conditional} = $sub; 682 } 683 $var =~ s/\s+//g; 684 $var =~ s:^!:: 685 and $noprompt = 1; 686 $var =~ s/\W+//g; 687 $var = lc $var; 688debug("conditional code: $subcode") if $Watch{$var}; 689 690 $cref->{help} = description($var); 691 $cref->{group} ||= $realgrp; 692 $grp = $cref->{group} || $var; 693 694 if(! $var and $cref->{group}) { 695 $Window{$cref->{group}} ||= { }; 696 $Window{$cref->{group}}->{banner} = $label || $prompt; 697 $Window{$cref->{group}}->{help} = 698 $Window{$cref->{group}}->{message} = description($cref->{group}); 699 push @addl_windows, $cref->{group}; 700 next; 701 } 702 elsif($grp ne $var) { 703 if (! $Window{$grp}) { 704 $Window{$grp} = { }; 705 push @addl_windows, $grp; 706 } 707 elsif($mainparam) { 708 $Window{$grp}{conditional} = $cref->{conditional} 709 if ! $Window{$grp}{conditional}; 710 } 711 $Window{$grp}{contents} = [] if ! $Window{$grp}{contents}; 712 push @{$Window{$grp}{contents}}, $var; 713 } 714 else { 715 push @addl_windows, $var; 716 } 717 718 my (@history) = split /\t/, $default; 719 $default = $Conf{$var} || $history[0] || ''; 720 721 if($label =~ /\S/) { 722 $cref->{banner} = $prompt; 723 $cref->{label} = $label; 724 } 725 else { 726 $cref->{label} = $prompt; 727 } 728 729 my $presubcode; 730 if($default =~ s/__MVC_([A-Z0-9]+)__/\$Conf{\L$1}/g) { 731 $default =~ s/\@/\\\@/g; 732 my $presubcode = qq{ 733 sub { 734 return qq[$default] 735 } 736 }; 737 my $presub = eval $presubcode; 738 if($@) { 739debug("error evaling prefix sub for $var: $presubcode"); 740 } 741 $cref->{prefix} = $presub; 742 $cref->{prefix_source} = $presubcode; 743 } 744 else { 745 $cref->{prefix} = $default; 746 } 747 $cref->{options} = \@history; 748 if ($noprompt) { 749 if($cref->{conditional}) { 750 my $snippet = <<EOF; 751 752 \$Conf{$var} = q{$default} if \$status; 753 return \$status; 754} 755EOF 756 # Appease vi { 757 $subcode =~ s/\s*return .*\s+}\s*$/$snippet/; 758 $cref->{conditional} = eval $subcode; 759 $cref->{conditional_source} = $subcode; 760 } 761 else { 762 $Conf{$var} = substitute($default); 763 $cref->{conditional} = sub { 0 }; 764 } 765 } 766 if($mainparam || $cref->{group}) { 767 my $winref; 768 if($cref->{group}) { 769 $winref = $Window{$cref->{group}}; 770 } 771 else { 772 $winref = $Content{$mainparam}; 773 $winref->{additional} ||= []; 774 push @{$winref->{additional}}, $var; 775 } 776 $winref->{override} ||= {}; 777 $winref->{override}{$var} = $cref; 778 $Content{$var} = $cref unless $Content{$var}; 779 } 780 elsif ($Content{$var}) { 781die("generated duplicate param for $var with no group or mainparam.\n"); 782debug("generated duplicate param for $var with no group or mainparam.\n"); 783 } 784 else { 785 $Content{$var} = $cref; 786 } 787#debug( "ref for $var: " . ::uneval($cref)); 788 } 789 close ADDLFIELDS; 790#debug("read_additional: returning: " . join ",", @addl_windows); 791 my %seen; 792 793 # Multiple conditions may define them more than once 794 @addl_windows = grep !$seen{$_}++, @addl_windows;; 795 return @addl_windows; 796} 797 798sub read_additional_new { 799 my ($help, @chunks) = @_; 800 my $winref; 801 my @addl_windows; 802 803 foreach my $cref (@chunks) { 804 my $grp; 805 my $subcode; 806 my $mainparam; 807 my $var; 808 my $default; 809 my $cond_code; 810 811 if(! ref $cref) { 812 # Bad chunk 813 next; 814 } 815 816 $cref->{_additional} = 1; 817 818 if($cond_code = $cref->{conditional}) { 819 delete $cref->{conditional}; 820 if($cond_code =~ /^sub\s+{.*}\s*$/s) { 821 $subcode = $cond_code; 822 } 823 else { 824 $cond_code =~ m{^[A-Z][A-Z0-9]+$} 825 and $cond_code = "\U__MVC_${cond_code}__"; 826 $cond_code =~ m{__MVC_([A-Z0-9]+)__} 827 and $mainparam = lc $1; 828 $cond_code =~ s{(['"]?)__MVC_([A-Z0-9]+)__\1} 829 {'$Conf{' . lc $2 . '}' }eg; 830 831 # Appease vi } 832 $subcode = <<EOF; 833 sub { 834 my \$status; 835 if($cond_code) { 836 \$status = 1; 837 } 838 else { 839 \$status = 0; 840 } 841 return \$status; 842 } 843EOF 844 } 845 } 846 847 if($subcode) { 848 my $sub = eval $subcode; 849 if($@) { 850debug("Problem evaluating sub: $subcode"); 851 undef $sub; 852 } 853 $cref->{conditional} = $sub; 854 } 855 856 for my $code (qw/callback/) { 857 my $cb = $cref->{$code} 858 or next; 859 if($cb =~ /^\s*sub\s+{/) { 860 # Appease vi } 861 local($SIG{__DIE__}); 862 $cref->{$code} = eval $cb; 863 $cref->{"${code}_source"} = $cb; 864 } 865 elsif($cb =~ /^\s*\[.*\]\s*$/s) { 866 $cref->{$code} = eval($cb); 867 $cref->{"${code}_source"} = $cb; 868 } 869 elsif($cb =~ /[a-z]/) { 870 my @items = Text::ParseWords::shellwords($cref->{$code}); 871 @items = map { lc $_ } @items; 872 $cref->{$code} = \@items; 873 $cref->{"${code}_source"} = $cb; 874 } 875 } 876 877 for my $code (qw/options history/) { 878 my $cb = $cref->{$code} 879 or next; 880 if($cb =~ /^\s*sub\s+{.*}\s*$/s) { 881 local($SIG{__DIE__}); 882 $cref->{$code} = eval $cb; 883 $cref->{"${code}_source"} = $cb; 884 } 885 elsif($cb =~ /^\s*\[.*\]\s*$/s) { 886 $cref->{$code} = eval($cb); 887 $cref->{"${code}_source"} = $cb; 888 } 889 elsif($cb =~ /[a-z]/) { 890 my @items = Text::ParseWords::shellwords($cref->{$code}); 891 $cref->{$code} = \@items; 892 $cref->{"${code}_source"} = $cb; 893 } 894 } 895 896 for my $code (qw/check_routine/) { 897 my $cb = $cref->{$code} 898 or next; 899 if($cb =~ /^\s*sub\s+{/) { 900 # Appease vi } 901 $cref->{$code} = eval $cb; 902 $cref->{"${code}_source"} = $cb; 903 } 904 else { 905 undef $cref->{$code}; 906 } 907 } 908 909 $var = $cref->{name} || $Wname++; 910 $var =~ s/\s+//g; 911 $var =~ s/\W+//g; 912 $cref->{name} = $var = lc $var; 913$::Subcode{$var} = $subcode; 914debug("conditional code: $subcode") if $Watch{$var}; 915 916 $grp = $cref->{group} || $var; 917 918 if($cref->{_window}) { 919 if(my $wref = $Window{$var}) { 920 for(keys %$wref) { 921 $cref->{$_} = $wref->{$_} 922 unless defined $cref->{$_}; 923 } 924 } 925 $cref->{help} ||= description($var); 926 $cref->{message} ||= $cref->{help}; 927 $cref->{banner} ||= $cref->{label}; 928 push @addl_windows, $var; 929 $Window{$var} = $cref; 930 next; 931 } 932 elsif($grp ne $var) { 933 if (! $Window{$grp}) { 934 $Window{$grp} = { }; 935 push @addl_windows, $grp; 936 } 937 elsif($mainparam) { 938 $Window{$grp}{conditional} = $cref->{conditional} 939 if ! $Window{$grp}{conditional}; 940 } 941 $Window{$grp}{contents} = [] if ! $Window{$grp}{contents}; 942 push @{$Window{$grp}{contents}}, $var; 943 } 944 else { 945 push @addl_windows, $var; 946 } 947 948 if(! $cref->{default} and ref $cref->{history} eq 'ARRAY') { 949 $cref->{default} = $cref->{history}[0]; 950 } 951 952 $cref->{help} ||= description($var); 953 $cref->{message} ||= $cref->{help}; 954 955 # Set default one of three ways 956 if($cref->{default}) { 957 $default = $cref->{default}; 958 } 959 960 if($default =~ /\t/ and ! $cref->{history}) { 961 $cref->{history} = [ split /\t/, $default ]; 962 $default =~ s/\t.*//; 963 $cref->{default} = $default; 964 } 965 $cref->{label} = $cref->{prompt} if ! $cref->{label}; 966 967 my $presubcode; 968 if($cref->{default} =~ s/__MVC_([A-Z0-9]+)__/\$Conf{\L$1}/g) { 969 $cref->{default} =~ s/\@/\\\@/g; 970 my $presubcode = qq{ 971 sub { 972 return qq[$cref->{default}] 973 } 974 }; 975 my $presub = eval $presubcode; 976 if($@) { 977debug("error evaling prefix sub for $var: $presubcode"); 978 } 979 $cref->{default} = $cref->{prefix} = $presub; 980 $cref->{default_source} = $presubcode; 981 } 982 else { 983 $cref->{default} = $cref->{prefix} = $default; 984 } 985 986 $cref->{options} = $cref->{history} if ! $cref->{options}; 987 if ($cref->{noprompt}) { 988 if($cref->{conditional}) { 989 # Appease vi { 990 my $snippet = <<EOF; 991 992 \$Conf{$var} = q{$default} if \$status; 993 return \$status; 994} 995EOF 996 # Appease vi { 997 $subcode =~ s/\s*return .*\s+}\s*$/$snippet/; 998 $cref->{conditional} = eval $subcode; 999 if($@) { 1000debug("Problem evaluating sub: $subcode"); 1001 } 1002 $cref->{conditional_source} = $presubcode; 1003 } 1004 else { 1005 $Conf{$var} = $default; 1006 $cref->{conditional} = sub { 0 }; 1007 } 1008 } 1009 if($cref->{always_set}) { 1010 $Conf{$var} = substitute($default); 1011 } 1012 1013 if($mainparam || $cref->{group}) { 1014 my $winref; 1015 if($cref->{group}) { 1016 $winref = $Window{$cref->{group}}; 1017 } 1018 else { 1019 $winref = $Content{$mainparam}; 1020 $winref->{additional} ||= []; 1021 push @{$winref->{additional}}, $var; 1022 } 1023 $winref->{override} ||= {}; 1024 $winref->{override}{$var} = $cref; 1025 } 1026 elsif ($Content{$var}) { 1027debug("generated duplicate param for $var with no group or mainparam."); 1028die("generated duplicate param for $var with no group or mainparam."); 1029 } 1030 else { 1031 $Content{$var} = $cref; 1032 push @addl_windows, $var; 1033 } 1034#debug( "ref for $var: " . ::uneval($cref)); 1035 } 1036 my %seen; 1037 1038 # Multiple conditions may define them more than once 1039 @addl_windows = grep !$seen{$_}++, @addl_windows;; 1040debug("read_additional returning windows: " . join ",", @addl_windows); 1041#debug("Here is the whole shebang:\n" . uneval(\%Window) . "\ncontent:\n" . uneval(\%Content)); 1042 return @addl_windows; 1043} 1044 1045sub read_common_config { 1046 my $data = shift; 1047#debug("read_common_config called with data=$data"); 1048 my @lines = split /\n/, $data; 1049 my $prev = ''; 1050 my $waiting; 1051 1052 my @out; 1053 my $out = \@out; 1054 my $wref; 1055 my $cref; 1056 1057 my $type; 1058 for(@lines) { 1059 # Strip CR, we hope 1060 s/\s+$//; 1061 1062 # Handle continued lines 1063 if(s/\\$//) { 1064 $prev .= $_; 1065 next; 1066 } 1067 elsif($waiting) { 1068 if($_ eq $waiting) { 1069 undef $waiting; 1070 $_ = $prev; 1071 $prev = ''; 1072 s/\s+$//; 1073 } 1074 else { 1075 $prev .= "$_\n"; 1076 next; 1077 } 1078 } 1079 elsif($prev) { 1080 $_ = "$prev$_"; 1081 $prev = ''; 1082 } 1083 1084 if (s/<<(\w+)$//) { 1085 $waiting = $1; 1086 $prev .= $_; 1087 next; 1088 } 1089 1090 next unless /\S/; 1091 next if /^\s*#/; 1092 if(m{ 1093 ^ \s* < 1094 (\w+) 1095 (?:\s+(\w[-\w]*\w))? 1096 \s*>\s* 1097 }x) 1098 { 1099 $type = lc $1; 1100 my $name = $2 || undef; 1101 if($name) { 1102 $name = lc $name; 1103 $name =~ tr/-/_/; 1104 } 1105 if(defined $cref and $cref->{_window} and $type ne 'window') { 1106 $wref = $cref; 1107 $out = $wref->{content_array} ||= []; 1108 } 1109 else { 1110 push @$out, $cref if $cref; 1111 } 1112 $cref = { "_$type" => 1, name => $name }; 1113 next; 1114 } 1115 elsif (m{^\s*</(\w[-\w]+\w)\s*>\s*}) { 1116 my $ender = lc $1; 1117 $ender =~ tr/-/_/; 1118 if(! $cref) { 1119 push @out, $wref if $wref; 1120 $out = \@out; 1121 undef $type; 1122 undef $wref; 1123 undef $cref; 1124 } 1125 elsif($ender eq $type) { 1126 if($type eq 'window') { 1127 push @out, ($wref || $cref); 1128 undef $cref; 1129 undef $wref; 1130 $out = \@out; 1131 } 1132 else { 1133 push @$out, $cref; 1134 undef $cref; 1135 } 1136 } 1137 else { 1138 die errmsg("Syntax error in config input: %s", $_); 1139 } 1140 next; 1141 } 1142 1143 s/^\s*(\w[-\w]*\w)(\s+|$)// 1144 or do { 1145 die "Problem reading config reference type=$type: $_\n"; 1146 }; 1147 my $parm = lc $1; 1148 $cref ||= {}; 1149 $parm =~ tr/-/_/; 1150 $cref->{$parm} = $_; 1151 } 1152 push @out, $cref if $cref; 1153 my @extra; 1154 for my $ref (@out) { 1155 if($ref->{content_array} and $ref->{_window}) { 1156 for (@{delete $ref->{content_array}}) { 1157 $_->{name} ||= $Wname++; 1158debug("popping $_->{name} from $ref->{name} content array"); 1159 $_->{group} = $ref->{name}; 1160 push @extra, $_; 1161 } 1162 } 1163 } 1164 push @out, @extra; 1165#debug("read_common_config: " . uneval(\@out) ); 1166 return @out; 1167} 1168 1169sub read_commands { 1170 my ($file, $wref) = @_; 1171 1172 my @data; 1173 my @files; 1174 my $pre_post; 1175 if(! $file) { 1176 @files = ( 1177 "$Conf{vendroot}/$Conf{demotype}/config/precopy_commands", 1178 "$Conf{vendroot}/$Conf{demotype}/config/postcopy_commands", 1179 ); 1180 $pre_post = 1; 1181 } 1182 else { 1183 @files = ($file); 1184 $wref = {} unless $wref; 1185 } 1186 1187 for (my $i = 0; $i < @files; $i++) { 1188 my $fn = $files[$i]; 1189 next if ! $fn; 1190 next if ! -f $fn; 1191 open CMDFILE, "< $fn" 1192 or do { 1193 my $msg = errmsg( 1194 "Cannot %s commands file %s: %s", 1195 errmsg('open'), 1196 $fn, 1197 $!, 1198 ); 1199 die "$msg\n"; 1200 }; 1201 local ($/); 1202 $data[$i] = <CMDFILE>; 1203 close CMDFILE 1204 or do { 1205 my $msg = errmsg( 1206 "Cannot %s commands file %s: %s", 1207 errmsg('close'), 1208 $fn, 1209 $!, 1210 ); 1211 die "$msg\n"; 1212 }; 1213 } 1214 1215 my $cmd_num = "cmd000"; 1216 1217 return undef unless @data; 1218 foreach my $block (@data) { 1219 my $root_msg = $> == 0 ? <<EOF : ''; 1220 1221Because you are root, you should be very careful 1222what commands you run. If you are unsure about the 1223ownership of any files, or of what the effects might 1224be, please uncheck the box next to the command. 1225EOF 1226 if($pre_post eq '1') { 1227 if(! $Window{precopy_commands}) { 1228 $Window{precopy_commands} = { 1229 contents => [], 1230 conditional => 0, 1231 message => 'Resolving catalog initialization commands', 1232 }; 1233 } 1234 $wref = $Window{precopy_commands}; 1235 $pre_post = 2; 1236 } 1237 elsif ($pre_post == 2) { 1238 if(! $Window{postcopy_commands}) { 1239 $Window{postcopy_commands} = { 1240 contents => [], 1241 banner => 'Resolving catalog finalization commands', 1242 }; 1243 } 1244 $wref = $Window{postcopy_commands}; 1245 $pre_post = 3; 1246 } 1247 next unless $block; 1248 1249 my @cmds; 1250 if($block =~ /^\s*</) { 1251 @cmds = read_common_config($block); 1252 } 1253 else { 1254 @cmds = split /\n\n+/, $block; 1255 } 1256 foreach my $cmd (@cmds) { 1257 my $cref; 1258 my $unprompted; 1259 my $subcode; 1260 my $mainparam; 1261 my ($command, $prompt); 1262 if(ref $cmd) { 1263 $cref = $cmd; 1264 $cmd = ''; 1265 } 1266 else { 1267 $cmd = substitute($cmd); 1268 $cmd =~ s/\\\n//g; 1269 $cref = {}; 1270 my $prompt; 1271 ($command, $prompt) = split /\n/, $cmd, 2; 1272 if($prompt =~ s/^\s*(\w+\s*=[^\n]*|{\s*\w+\s*=.*})\s*\n//s) { 1273 my $extra = $1; 1274#debug("Found command mods: $extra"); 1275 my $ref = get_option_hash($extra); 1276#debug("Command mods: " . uneval($ref)); 1277 if (ref $ref) { 1278 for (keys %$ref) { 1279 $cref->{$_} = $ref->{$_}; 1280 } 1281 } 1282 else { 1283 warn "Unsuccessful command option parse: $extra\n"; 1284 } 1285 } 1286 $cref->{help} = $prompt if ! $cref->{help}; 1287 } 1288 if($cref->{window_indicator}) { 1289 $wref ||= $Window{$cref->{name}}; 1290 for(keys %$cref) { 1291 $wref->{$_} = $cref->{$_}; 1292 } 1293 next; 1294 } 1295 $cref->{widget} = 'yesno' if ! $cref->{widget}; 1296 $command = $cref->{command} if ! $command; 1297 $command =~ s/^\s+//; 1298 $command =~ s/\s+$//; 1299 $command =~ s/^!// and $> != 0 and $cref->{unprompted} = 1; 1300 delete $wref->{conditional} 1301 if $wref->{conditional} eq '0' 1302 and $pre_post; 1303 1304 if($command =~ s/{\s*([A-Z0-9]+)(\s*\S.*?)?\s*}\s*//) { 1305 $mainparam = lc $1; 1306 my $test = $2; 1307 $test =~ s{(['"]?)__MVC_([A-Z0-9]+)__\1} 1308 {'\$Conf{' . lc $2 . '}' }eg; 1309 $subcode = <<EOF; 1310 sub { 1311 my \$status; 1312#debug("conditional checking param=$mainparam testing=$test Value=\$Conf{$mainparam}"); 1313 if(\$Conf{$mainparam} $test) { 1314 \$status = 1; 1315 } 1316 else { 1317 \$status = 0; 1318 } 1319#debug("conditional routine returning \$status"); 1320 return \$status; 1321 } 1322EOF 1323 } 1324 elsif ( $cref->{conditional} ) { 1325 $cref->{conditional} =~ s/^[A-Z0-9a-z]+$/__MVC_\U${1}__/; 1326 $cref->{conditional} =~ s{(['"]?)__MVC_([A-Z0-9]+)__\1} 1327 {'\$Conf{' . lc $2 . '}' }eg; 1328 # Make vi happy: } } 1329 $subcode = delete $cref->{conditional}; 1330 } 1331 1332#debug("read_commands: sub=$subcode"); 1333 if($subcode) { 1334 $subcode = "sub {\n" . $cref->{conditional} . "}" 1335 unless $subcode =~ /^\s*sub\s+{/; 1336 my $sub = eval $subcode; 1337 if($@) { 1338debug("read_commands: Problem evaluating sub: $subcode"); 1339 undef $sub; 1340 } 1341 $cref->{conditional} = $sub; 1342 } 1343 1344 $cref->{command} = $command; 1345 $cref->{label} = $command if ! $cref->{label}; 1346 $cref->{name} = $cmd_num++ unless $cref->{name}; 1347 my $name = $cref->{name}; 1348 $Content{$name} = $cref; 1349 if(my $gname = $cref->{group}) { 1350 $Window{$gname}->{contents} ||= []; 1351 push @{$Window{$gname}->{contents}}, $name; 1352 } 1353 else { 1354 push @{$wref->{contents}}, $name; 1355 } 1356 } 1357 } 1358 if($pre_post) { 1359 return ($Window{precopy_commands}, $Window{postcopy_commands}); 1360 } 1361 else { 1362 return $wref; 1363 } 1364} 1365 1366 1367# Validate a field against: 1368# 1369# check_regex -- a regular expression which must succeeed 1370# check_blank -- Just needs a non-blank value 1371# check_routine -- a subroutine which can return -1, 0, 1 1372# check_message -- a template (from errmsg) which can be used 1373# 1374# If the return value is -1, then the error message is assumed 1375# to have been handled by the check_routine and is not returned. 1376# 1377sub validate { 1378 my ($val, $parm) = @_; 1379 my $thing = $Content{$parm}; 1380 if(! $parm or ! $thing) { 1381 return (0, errmsg('blank')); 1382 } 1383 1384 my $status; 1385 my $message = $thing->{check_message}; 1386 my $errmsg; 1387 1388 if($thing->{check_regex}) { 1389 $errmsg = errmsg('blank'); 1390 $status = length($val) ? 1 : 0; 1391 } 1392 elsif($thing->{check_regex}) { 1393 my $regex = qr/$thing->{check_regex}/; 1394 $status = $val =~ $regex; 1395 } 1396 elsif($thing->{check_routine}) { 1397 ($status, $errmsg) = $thing->{check_routine}->($val, $parm); 1398 } 1399 else { 1400 $status = 1; 1401 } 1402 1403 ## This allows directly returning error and no confirm screen 1404 return $status if abs($status); 1405 $message = "%s (value '%s'): failed validation" 1406 if ! $message; 1407 my $lab = label($parm) || $parm; 1408 $message = errmsg($message, $lab, $val, $parm); 1409 return($status, $message); 1410} 1411 1412sub prefix { 1413 my ($parm, $nodefault, $override) = @_; 1414 $parm = lc $parm; 1415 if($Alias{$parm} and $Conf{$parm}) { 1416 $Conf{$parm} = $Alias{$parm}{$Conf{$parm}}; 1417 } 1418 return $Conf{$parm} if $Conf{$parm}; 1419 return $ENV{"MVC_\U$parm"} if $ENV{"MVC_\U$parm"}; 1420 return undef if $nodefault; 1421 my $thing = $Content{$parm}{prefix} || $Prefix{$parm}; 1422 if(ref $thing eq 'CODE') { 1423 return $thing->(); 1424 } 1425 elsif(ref $thing eq 'ARRAY') { 1426 return $thing->[0]; 1427 } 1428 else { 1429 return $thing; 1430 } 1431} 1432 1433%Special_sub= ( 1434 cryptpw => sub { 1435 my $pw = shift; 1436 return $pw if $Conf{alreadycrypt}; 1437 my @letters = ('A' .. 'Z', 'a' .. 'z'); 1438 my $salt = $letters[ int rand(scalar @letters) ]; 1439 $salt .= $letters[ int rand(scalar @letters) ]; 1440 return crypt($pw, $salt); 1441 }, 1442); 1443 1444sub substitute { 1445 my($parm) = @_; 1446 if($parm !~ /^\w+$/) { 1447 $parm =~ s/__MVC_([A-Z0-9]+)__/$Conf{lc $1}/eg; 1448 } 1449 elsif (defined $ENV{"MVC_$parm"}) { 1450 $parm = $ENV{"MVC_$parm"}; 1451 } 1452 elsif (my $sub = $Special_sub{lc $parm}) { 1453 if(ref $sub) { 1454 $parm = $sub->($Conf{lc $parm}); 1455 } 1456 else { 1457 $parm = $sub; 1458 $parm =~ s/__MVC_([A-Z0-9]+)__/$Conf{lc $1}/eg; 1459 } 1460 } 1461 else { 1462 $parm = $Conf{lc $parm}; 1463 } 1464 $parm = '' unless defined $parm; 1465 return $parm; 1466} 1467 1468sub sum_it { 1469 my ($file) = @_; 1470 open(IT, "<$file") 1471 or return undef; 1472 my $data = ''; 1473 $data .= $_ while (<IT>); 1474 close IT; 1475 return unpack("%32c*", $data); 1476} 1477 1478sub strip_na { 1479 my $val = shift; 1480 return '' if lc($val) eq 'n/a'; 1481 return $val; 1482} 1483 1484 1485sub directory_process { 1486 my $dir = shift; 1487 $dir =~ s:[/\s]+$::; 1488 if($Conf{catuser} and $dir =~ /^~/) { 1489 my $userdir = ( getpwnam( $Conf{catuser} ) )[7]; 1490 $dir =~ s/^~/$userdir/ if $userdir; 1491 } 1492 return $dir; 1493} 1494 1495sub strip_trailing_slash { 1496 my $url = shift; 1497 $url =~ s:[/\s]+$::; 1498 return $url; 1499} 1500 1501 1502sub inet_host { 1503 return scalar find_inet_info('h'); 1504} 1505 1506sub inet_port { 1507 return scalar find_inet_info('p'); 1508} 1509 1510sub find_inet_info { 1511 my $type = shift; 1512 my (@hosts); 1513 my (@ports); 1514 my $prog = "$Conf{relocate}$Conf{vendroot}/src/tlink"; 1515 my $the_one = sum_it($prog); 1516 my $defport = '7786'; 1517 my $defhost = '127.0.0.1'; 1518 1519 my @poss = glob("$Conf{relocate}$Conf{vendroot}/src/tlink.*.*"); 1520 for (@poss) { 1521 my $name = $_; 1522 /tlink\.(.*)\.(\d+)$/ 1523 or next; 1524 my ($h, $p) = ($1, $2); 1525 push @hosts, $h; 1526 push @ports, $p; 1527 my $one = sum_it($_); 1528 next unless $one eq $the_one; 1529 $defhost = $h; 1530 $defport = $p; 1531 } 1532 1533 if(! $type) { 1534 my %seen; 1535 @ports = grep !$seen{$_}++, @ports; 1536 %seen = (); 1537 @hosts = grep !$seen{$_}++, @hosts; 1538 return (\@hosts, \@ports); 1539 } 1540 elsif ($type =~ /^h/i) { 1541 return $defhost; 1542 } 1543 elsif ($type =~ /^p/i) { 1544 return $defport; 1545 } 1546} 1547 1548sub applicable_directive { 1549 my ($direc, $routine) = @_; 1550 $direc = lc($direc); 1551 if($routine) { 1552 return undef if ! $routine->($direc); 1553 } 1554 return $direc if ! defined $IfRoot{$direc}; 1555 return undef if $Conf{asroot} xor $IfRoot{$direc}; 1556 return $direc; 1557} 1558 1559 1560sub findexe { 1561 my($exe) = @_; 1562 my($dir,$path) = ('', $ENV{PATH}); 1563 $path =~ s/\(\)//g; 1564 $path =~ s/\s+/ /g; 1565 my(@dirs) = split /[\s:]+/, $path; 1566 foreach $dir (@dirs) { 1567 return "$dir/$exe" if -x "$dir/$exe"; 1568 } 1569 return ''; 1570} 1571 1572sub findfiles { 1573 my($file) = @_; 1574 return undef if $^O =~ /win32/i; 1575 my $cmd; 1576 my @files; 1577 if($cmd = findexe('locate')) { 1578 @files = `locate \\*/$file`; 1579 } 1580 else { 1581 @files = `find / -name $file -print 2>/dev/null`; 1582 } 1583 return undef unless @files; 1584 chomp @files; 1585 return @files; 1586} 1587 1588sub pretty { 1589 my($parm) = @_; 1590 return defined $Pretty{lc $parm} ? $Pretty{lc $parm} : $parm; 1591} 1592 1593sub history { 1594 my $parm = shift; 1595 $parm = lc $parm; 1596 return unless defined $History{$parm}; 1597 my @things = $History{$parm}->(@_); 1598 return wantarray ? @things : \@things; 1599} 1600 1601sub error_message { 1602 my($parm) = @_; 1603 $parm = lc $parm; 1604 return defined $Validate{$parm} ? $Validate{$parm} : ''; 1605} 1606 1607sub label { 1608 my($parm) = @_; 1609 return defined $Label{lc $parm} ? $Label{lc $parm} : ''; 1610} 1611 1612sub description { 1613 my($parm) = @_; 1614 return defined $Desc{lc $parm} ? $Desc{lc $parm} : ''; 1615} 1616 1617sub can_do_suid { 1618 return 0 if $^O =~ /win32/i; 1619 my $file = "tmp$$.fil"; 1620 my $status; 1621 1622 open(TEMPFILE,">$file"); 1623 close TEMPFILE; 1624 eval { chmod 04755, $file; $@ = ''}; 1625 $status = $@ ? 0 : 1; 1626 unlink $file; 1627 return $status; 1628} 1629 1630sub get_id { 1631 return 'everybody' if $^O =~ /win32/i; 1632 my $file = -f "$Global::VendRoot/error.log" 1633 ? "$Global::VendRoot/error.log" : ''; 1634 return '' unless $file; 1635 my ($name); 1636 1637 my($uid) = (stat($file))[4]; 1638 $name = (getpwuid($uid))[0]; 1639 return $name; 1640} 1641 1642sub get_ids { 1643 return ('everybody', 'nogroup') if $^O =~ /win32/i; 1644 my $file = "tmp$$.fil"; 1645 my ($name, $group); 1646 1647 open(TEMPFILE,">$file"); 1648 close TEMPFILE; 1649 my($uid,$gid) = (stat($file))[4,5]; 1650 unlink $file; 1651 $name = (getpwuid($uid))[0]; 1652 $group = (getgrgid($gid))[0]; 1653 return ($name,$group); 1654} 1655 1656sub get_rename { 1657 my ($bn, $extra) = @_; 1658 $extra = '~' unless $extra; 1659 $bn =~ s:(.*/)::; 1660 my $dn = $1; 1661 return $dn . "/.$extra." . $bn; 1662} 1663 1664sub compare_file { 1665 my($first,$second) = @_; 1666 return 0 unless -f $first && -f $second; 1667 return 0 unless -s $first == -s $second; 1668 local $/; 1669 open(FIRST, "< $first") or return undef; 1670 open(SECOND, "< $second") or (close FIRST and return undef); 1671 binmode(FIRST); 1672 binmode(SECOND); 1673 $first = ''; 1674 $second = ''; 1675 while($first eq $second) { 1676 read(FIRST, $first, 1024); 1677 read(SECOND, $second, 1024); 1678 last if length($first) < 1024; 1679 } 1680 close FIRST; 1681 close SECOND; 1682 $first eq $second; 1683} 1684 1685sub set_owner { 1686 return unless $> == 0; 1687 my($file) = @_; 1688 resolve_owner() 1689 unless $Conf{interchangeuid}; 1690 1691 my ($user, $group) = ($Conf{interchangeuid}, $Conf{interchangegid}); 1692 die errmsg("Can't find info: %s", 'interchangeuid') 1693 unless $Conf{interchangeuid}; 1694 1695 if($Conf{permtype} =~ /^m/i) { 1696 $user = $Conf{catuseruid}; 1697 $group = $Conf{catusergid}; 1698 } 1699 elsif($Conf{permtype} =~ /^g/i) { 1700 $group = $Conf{catusergid}; 1701 } 1702 chown($user, $group, $file) 1703 or die errmsg( 1704 "Couldn't set ownership to UID=%s GID=%s for %s: %s", 1705 $user, 1706 $group, 1707 $file, 1708 $!, 1709 ); 1710} 1711 1712sub install_file { 1713 my ($srcdir, $targdir, $filename, $opt) = @_; 1714 $opt = {} unless $opt; 1715 my $save_umask; 1716 if($opt->{umask} ) { 1717 $save_umask = umask $opt->{umask}; 1718 local($SIG{__DIE__}) = sub { umask $save_umask; warn @_; exit 1 }; 1719 } 1720 1721 my $scale; 1722 if($scale = $opt->{scale_call}) { 1723 $scale->( 'start', $opt->{scale}, $opt->{message}); 1724 } 1725 1726 if (ref $srcdir) { 1727 $opt = $srcdir; 1728 $srcdir = $opt->{Source} || die "Source dir for install_file not set.\n"; 1729 $targdir = $opt->{Target} || die "Target dir for install_file not set.\n"; 1730 $filename = $opt->{Filename} || die "File name for install_file not set.\n"; 1731 } 1732 my $srcfile = $srcdir . '/' . $filename; 1733 my $targfile = $targdir . '/' . $filename; 1734 my $mkdir = File::Basename::dirname($targfile); 1735 my $extra; 1736 my $perms; 1737 1738 1739 if(! -d $mkdir) { 1740 File::Path::mkpath($mkdir, undef, $opt->{dmode} || 0777) 1741 or die "Couldn't make directory $mkdir: $!\n"; 1742 chmod($opt->{dmode}, $mkdir) if $opt->{dmode}; 1743 set_owner($mkdir); 1744 } 1745 1746 if (! -f $srcfile) { 1747 die "Source file $srcfile missing.\n"; 1748 } 1749 elsif ( 1750 $opt->{perm_hash} 1751 and $opt->{perm_hash}->{$filename} 1752 ) 1753 { 1754 $perms = $opt->{perm_hash}->{$filename}; 1755 } 1756 elsif ($opt->{fmode}) { 1757 $perms = $opt->{fmode}; 1758 } 1759 elsif ( $opt->{Perms} =~ /^(m|g)/i ) { 1760 $perms = (stat(_))[2] | 0660; 1761 } 1762 elsif ( $opt->{Perms} =~ /^u/i ) { 1763 $perms = (stat(_))[2] | 0600; 1764 } 1765 else { 1766 $perms = (stat(_))[2] & 0777; 1767 } 1768 1769 if( ! $Global::Win32 and -f $targfile and ! compare_file($srcfile, $targfile) ) { 1770 open (GETVER, "< $targfile") 1771 or die "Couldn't read $targfile for version update: $!\n"; 1772 while(<GETVER>) { 1773 /VERSION\s+=.*?\s+([\d.]+)/ or next; 1774 $extra = $1; 1775 $extra =~ tr/0-9//cd; 1776 last; 1777 } 1778 $extra = '~' unless $extra; 1779 my $rename = get_rename($targfile, $extra); 1780 while (-f $rename ) { 1781 $extra .= '~'; 1782 $rename = get_rename($targfile, $extra); 1783 } 1784 rename $targfile, $rename 1785 or die "Couldn't rename $targfile to $rename: $!\n"; 1786 } 1787 1788 File::Copy::copy($srcfile, $targfile) 1789 or die "Copy of $srcfile to $targfile failed: $!\n"; 1790 if($opt->{Substitute}) { 1791 my $bak = "$targfile.mv"; 1792 rename $targfile, $bak; 1793 open(SOURCE, "< $bak") 1794 or die errmsg("%s %s: %s\n", errmsg("open"), $bak, $!); 1795 open(TARGET, ">$targfile") 1796 or die errmsg("%s %s: %s\n", errmsg("create"), $bak, $!); 1797 local($/) = undef; 1798 my $page = <SOURCE>; close SOURCE; 1799 1800 $page =~ s/^#>>(.*)(__MVR_(\w+)__.*)\n\1.*/#>>$1$2/mg; 1801 $page =~ s/^#>>(.*__MVR_(\w+)__.*)/#>>$1\n$1/mg; 1802 1 while $page =~ s/^([^#].*)__MVR_(.*)/$1__MVC_$2/mg; 1803 $page =~ s/__MV[CS]_([A-Z0-9]+)__/$opt->{Substitute}{lc $1}/g; 1804 1805 print TARGET $page or die "print $targfile: $!\n"; 1806 close TARGET or die "close $targfile: $!\n"; 1807 unlink $bak or die "unlink $bak: $!\n"; 1808 } 1809 1810 chmod $perms, $targfile; 1811 $scale->('end') if $scale; 1812 umask $save_umask if $save_umask; 1813 return 1; 1814} 1815 1816sub debug { 1817 for(@_) { 1818 print DEBUG "$_\n"; 1819 } 1820 return; 1821} 1822 1823sub copy_current_to_dir { 1824 my($target_dir, $exclude_pattern) = @_; 1825 return copy_dir('.', $target_dir, $exclude_pattern); 1826} 1827 1828sub copy_dir { 1829 my($source_dir, $target_dir, $exclude_pattern, $opt) = @_; 1830 return undef unless -d $source_dir; 1831 $opt = {} unless $opt; 1832 my $scale; 1833 if($scale = $opt->{scale_call}) { 1834 $scale->('start', $opt->{scale}, $opt->{message}); 1835 } 1836 my $orig_dir; 1837 if($source_dir ne '.') { 1838 $orig_dir = cwd(); 1839 chdir $source_dir or die "chdir: $!\n"; 1840 } 1841 my @files; 1842 my $wanted = sub { 1843 return unless -f $_; 1844 my $name = $File::Find::name; 1845 $name =~ s:^\./::; 1846 return if $exclude_pattern and $name =~ m{$exclude_pattern}o; 1847 push (@files, $name); 1848 }; 1849 File::Find::find($wanted, '.'); 1850 1851 # also exclude directories that match $exclude_pattern 1852 @files = grep !m{$exclude_pattern}o, @files if $exclude_pattern; 1853 eval { 1854 for(@files) { 1855 install_file('.', $target_dir, $_, $opt); 1856 } 1857 }; 1858 my $msg = $@; 1859 chdir $orig_dir if $orig_dir; 1860 die "$msg" if $msg; 1861 return 1; 1862} 1863 1864use vars q!$Prompt_sub!; 1865my $History_add; 1866my $History_set; 1867my $term; 1868eval { 1869 require Term::ReadLine; 1870 import Term::ReadLine; 1871 1872 $term = new Term::ReadLine 'Interchange Configuration'; 1873 die "No Term::ReadLine" unless defined $term; 1874 1875 readline::rl_set('CompleteAddsuffix', 'Off'); 1876 readline::rl_set('TcshCompleteMode', 'On'); 1877 $Prompt_sub = sub { 1878 my ($prompt, $default) = @_; 1879 if($Force) { 1880 print "$prompt SET TO --> $default\n"; 1881 return $default; 1882 } 1883 $prompt =~ s/^\s*(\n+)/print $1/ge; 1884 $prompt =~ s/\n+//g; 1885 readline::rl_bind('C-x', 'catch-cancel'); 1886 readline::rl_bind('C-b', 'catch-backward'); 1887 readline::rl_bind('C-y', 'catch-help'); 1888 readline::rl_bind('C-f', 'catch-forward'); 1889 if(! $Conf{vi_edit_mode}) { 1890 readline::rl_bind('"\M-\OP"', 'catch-help'); 1891 readline::rl_bind('"\M-[20"', 'catch-backward'); 1892 readline::rl_bind('"\M-[21"', 'catch-forward'); 1893 #readline::rl_bind('"\M-[1"', 'catch-cancel'); 1894 readline::rl_bind('"\M-[5"', 'catch-backward'); 1895 readline::rl_bind('"\M-[6"', 'catch-forward'); 1896 } 1897 my $out = $term->readline($prompt, $default); 1898 return "\cB" if ! defined $out; 1899 return $out; 1900 }; 1901 $History_add = sub { 1902 my ($line) = @_; 1903 $term->addhistory($line) 1904 if $line =~ /\S/; 1905 }; 1906 $History_set = sub { 1907 $term->SetHistory(@_); 1908 }; 1909 $History = 1; 1910 1911}; 1912 1913sub prompt { 1914 return &$Prompt_sub(@_) 1915 if defined $Prompt_sub; 1916 my($prompt) = shift || '? '; 1917 my($default) = shift; 1918 if($Force) { 1919 print "$prompt SET TO --> $default\n"; 1920 return $default; 1921 } 1922 my($ans); 1923 1924 print $prompt; 1925 print "[$default] " if $default; 1926 local ($/) = "\n"; 1927 chomp($ans = <STDIN>); 1928 length($ans) ? $ans : $default; 1929} 1930 1931sub addhistory { 1932 return '' unless defined $History_add; 1933 return $History_add->(@_); 1934} 1935 1936sub sethistory { 1937 return '' unless defined $History_set; 1938 return $History_set->(@_); 1939} 1940 1941sub do_msg { 1942 my ($msg, $size) = @_; 1943 $size = 60 unless defined $size; 1944 my $len = length $msg; 1945 1946 return "$msg.." if ($len + 2) >= $size; 1947 $msg .= '.' x ($size - $len); 1948 return $msg; 1949} 1950 1951sub add_catalog { 1952 my ($file, $directive, $configname, $value) = @_; 1953 if(! $file) { 1954 $file = "$Conf{relocate}$Global::ConfigFile"; 1955 } 1956 $configname = $Conf{catalogname} if ! $configname; 1957 $directive = 'Catalog' if ! $directive; 1958 if (! $value) { 1959 $value = "$Conf{catalogname} $Conf{catroot} $Conf{cgiurl}"; 1960 $value .= " $Conf{aliases}" if $Conf{aliases}; 1961 } 1962 my ($newcfgline, $mark, @out); 1963 my ($tmpfile) = "$file.$$"; 1964 if (-f $file) { 1965 rename ($file, $tmpfile) 1966 or die "Couldn't rename $file: $!\n"; 1967 } 1968 else { 1969 File::Copy::copy("$file.dist", $tmpfile) 1970 or die errmsg("Couldn't find interchange.cfg"); 1971 } 1972 open(CFG, "< $tmpfile") 1973 or die "Couldn't open $tmpfile: $!\n"; 1974 $newcfgline = sprintf "%-19s %s\n", $directive, $value; 1975 while(<CFG>) { 1976 $mark = $. if /^#?\s*catalog\s+/i; 1977debug("\nDeleting old configuration $configname.\n") if s/^(\s*$directive\s+$configname\s+)/#$1/io; 1978 push @out, $_; 1979 } 1980 close CFG; 1981 open(NEWCFG, ">$file") 1982 or die "\nCouldn't write $file: $!\n"; 1983 if (defined $mark) { 1984 print NEWCFG @out[0..$mark-1]; 1985 print NEWCFG $newcfgline; 1986 print NEWCFG @out[$mark..$#out]; 1987 } 1988 else { 1989 warn "\nNo $directive previously defined. Adding $configname at top.\n"; 1990 print NEWCFG $newcfgline; 1991 print NEWCFG @out; 1992 } 1993 close NEWCFG || die errmsg("%s %s: %s\n", 'close', $file, $!); 1994 unlink $tmpfile; 1995} 1996 1997sub server_running { 1998 local ($/); 1999debug("in server_running, pid file=$Global::PIDfile"); 2000 open(PID, "+< $Global::PIDfile") 2001 or return undef; 2002debug("opened PID file"); 2003 if(Vend::Util::lockfile(\*PID, 1, 0)) { 2004debug("PID file not locked"); 2005 ## Daemon not running; 2006 close PID; 2007 return undef; 2008 } 2009 my $pid = <PID>; 2010debug("PID=$pid"); 2011 $pid =~ /(\d+)/; 2012 $pid = $1; 2013 return $pid; 2014} 2015 2016sub run_catalog { 2017 my ($file, $directive, $configname, $value) = @_; 2018 $Conf{relocate} 2019 and die errmsg("Can't add catalog to running server when relocating."); 2020 2021 if(! $file) { 2022 my $fn = 'restart'; 2023 $file = "$Global::RunDir/$fn"; 2024 } 2025 2026 $configname = $Conf{catalogname} if ! $configname; 2027 $directive = 'Catalog' if ! $directive; 2028 if (! $value) { 2029 $value = "$Conf{catalogname} $Conf{catroot} $Conf{cgiurl}"; 2030 $value .= " $Conf{aliases}" if $Conf{aliases}; 2031 } 2032 my $pid = server_running(); 2033 if(! defined $pid) { 2034 die errmsg("Can't add %s to server: not running", $configname); 2035 } 2036 2037 open(RESTART, "<+$file") 2038 or open(RESTART, ">>$file") 2039 or die errmsg("%s %s: %s\n", errmsg("write"), $file, $!); 2040 Vend::Util::lockfile(\*RESTART, 1, 1) 2041 or die errmsg("%s %s: %s\n", errmsg("lock"), $file, $!); 2042 printf RESTART "%-19s %s\n", $directive, $value; 2043 Vend::Util::unlockfile(\*RESTART) 2044 or die errmsg("%s %s: %s\n", errmsg("unlock"), $file, $!); 2045 close RESTART; 2046 set_owner($file); 2047 kill 'HUP', $pid; 2048} 2049 2050my %Http_hash = ( 2051 qw( 2052 scriptalias 1 2053 addhandler 1 2054 alias 1 2055 ) 2056 ); 2057 2058my %Http_process = ( 2059 scriptalias => sub { 2060 my ($junk, $val) = @_; 2061 $val =~ s!/+$!!; 2062 return $val; 2063 }, 2064 ); 2065 2066my %Http_scalar = ( 2067 qw( 2068 user 1 2069 group 1 2070 serveradmin 1 2071 resourceconfig 1 2072 documentroot 1 2073 ) 2074 ); 2075 2076 2077sub conf_parse_http { 2078 my ($file) = @_; 2079 2080 my $virtual = {}; 2081 my $servers = {}; 2082 my $newfile; 2083 2084 open(HTTPDCONF, "< $file") 2085 or do { $Error = "Can't open $file: $!"; return undef}; 2086 local($/) = undef; 2087 my $data = <HTTPDCONF>; 2088 close(HTTPDCONF); 2089 2090 2091 if($data =~ s/^\s*resourceconfig\s+("?)(.*)\1//i) { 2092 $newfile = $2; 2093 } 2094 2095 unless(defined $newfile) { 2096 $newfile = $file; 2097 $newfile =~ s:[^/]+$::; 2098 $newfile .= 'srm.conf'; 2099 } 2100 2101 SRMCONF: { 2102 if (-f $newfile) { 2103 open(HTTPDCONF, "< $newfile") 2104 or last SRMCONF; 2105 $data .= <HTTPDCONF>; 2106 close(HTTPDCONF); 2107 } 2108 } 2109 2110 $data =~ s! 2111 <virtualhost 2112 \s+ 2113 ([^>\n]+) 2114 \s*>\s+ 2115 ([\000-\377]*?) 2116 </virtualhost>! 2117 $virtual->{$1} = $2; ''!xieg; 2118 2119 $virtual->{' '} = $data; 2120 2121 my @data; 2122 my $servname; 2123 my $handle; 2124 my $main; 2125 foreach $handle (sort keys %$virtual) { 2126 2127 undef $servname; 2128 @data = split /[\r\n]+/, $virtual->{$handle}; 2129 my $port = $handle; 2130 $port =~ s/.*:(\d+).*/$1/ or $port = ''; 2131 @data = grep /^\s*[^#]/, @data; 2132 for(@data) { 2133 next unless /^\s*servername\s+(.*)/i; 2134 $servname = $1; 2135 $servname =~ s/\s+$//; 2136 if(defined $servers->{$servname} and $port) { 2137 $servname .= ":$port"; 2138 } 2139 elsif(defined $servers->{$servname} and $port) { 2140 $Error = "Server $servname defined twice."; 2141 return undef; 2142 } 2143 $servers->{$servname} = {}; 2144 } 2145 2146 if($handle eq ' ') { 2147 $servname = Sys::Hostname::hostname() unless $servname; 2148 $servname =~ s/\s+$//; 2149 $main = $servname; 2150 $servers->{$servname} = {} if ! $servers->{$servname}; 2151 $servers->{$servname}{Master} = 1; 2152 } 2153 next unless $servname; 2154 2155 my $ref = $servers->{$servname}; 2156 2157 $ref->{servername} = $servname; 2158 2159 foreach my $line (@data) { 2160 $line =~ s/^\s+//; 2161 $line =~ s/\s+$//; 2162 my ($key, $val); 2163 my ($directive,$param) = split /\s+/, $line, 2; 2164 $directive = lc $directive; 2165 if(defined $Http_hash{$directive}) { 2166 $ref->{$directive} = {} 2167 unless defined $ref->{$directive}; 2168 my ($key,$val) = split /\s+/, $param, 2; 2169 $val =~ s/^\s*"// and $val =~ s/"\s*$//; 2170 if (defined $Http_process{$directive}) { 2171 $key = $Http_process{$directive}->('key', $key); 2172 $val = $Http_process{$directive}->('value', $val); 2173 } 2174 $ref->{$directive}{$key} = $val; 2175 } 2176 elsif(defined $Http_scalar{$directive}) { 2177 $param =~ s/^"// and $param =~ s/"\s*$//; 2178 if (defined $ref->{$directive}) { 2179 undef $ref; 2180 $Error = "$directive defined twice in $servname, only allowed once."; 2181 return undef; 2182 } 2183 if (defined $Http_process{$directive}) { 2184 $param = $Http_process{$directive}->($param); 2185 } 2186 $ref->{$directive} = $param; 2187 } 2188 } 2189 } 2190 2191 return $servers; 2192} 2193 2194sub substitute_cryptpw { 2195 my $pw = $Conf{cryptpw}; 2196 return unless $pw; 2197 return if $Conf{alreadycrypt}++; 2198 my @letters = ('A' .. 'Z', 'a' .. 'z'); 2199 my $salt = $letters[ int rand(scalar @letters) ]; 2200 $salt .= $letters[ int rand(scalar @letters) ]; 2201 $Conf{cryptpw} = crypt($pw, $salt); 2202} 2203 2204sub unique_ary { 2205 my %seen; 2206 %seen = (); 2207 return ( grep !$seen{$_}++, @_ ); 2208} 2209 2210sub resolve_owner { 2211 my $cref = shift || \%Conf; 2212 die errmsg("Usage: %s", "resolve_owner({ })") 2213 unless ref $cref eq 'HASH'; 2214 return unless $> == 0 || $cref->{asroot}; 2215 my @things = qw/interchangeuser interchangegroup catuser catgroup/; 2216 my ($icu, $icg, $catu, $catg) = @$cref{@things}; 2217 2218 $catu = $icu if ! $catu; 2219 2220 # Default groups 2221 my $icd; 2222 my $catd; 2223 2224 my($icu_uid, $catu_uid, $icg_gid, $catg_gid); 2225 $icu_uid = getpwnam($icu) 2226 or die errmsg("User does not exist: %s\n", $icu); 2227 $catu_uid = getpwnam($catu) 2228 or die errmsg("User does not exist: %s\n", $catu); 2229 2230 if($cref->{permtype} =~ /^\s*m/i) { 2231 $icg_gid = (getpwnam($catu))[3] if ! $icg; 2232 $catg_gid = (getpwnam($catu))[3]; 2233 } 2234 elsif($cref->{permtype} =~ /^\s*g/i) { 2235 $icg_gid = (getpwnam($icu))[3] if ! $icg; 2236 $catg_gid = (getpwnam($icu))[3]; 2237 } 2238 else { 2239 $icg_gid = (getpwnam($catu))[3] if ! $icg; 2240 $catg_gid = (getpwnam($catu))[3]; 2241 } 2242 $icg_gid = (getpwnam($icu))[3] if ! $icg_gid; 2243 $catg_gid = (getpwnam($catu))[3] if ! $catg_gid; 2244 2245 @$cref{qw/ 2246 interchangeuid 2247 interchangegid 2248 catuid 2249 catgid 2250 /} = ($icu_uid, $icg_gid, $catu_uid, $catg_gid); 2251 return $cref; 2252} 2253 2254sub hammer_symlinks { 2255 my $dir = shift; 2256 File::Find::find( 2257 sub { 2258 return if ! -l $_; 2259 unlink $_ 2260 or die "couldn't unlink $File::Find::name: $!\n"; 2261 }, 2262 $dir, 2263 ); 2264 return 1; 2265} 2266 2267 2268 2269sub check_root_execute { 2270 my $dir = shift; 2271 return undef if ! -d $dir; 2272 my @disc; 2273 my $wanted = sub { 2274 my @stat = stat($_); 2275 my $type = -d _ ? 'directory' : 'file'; 2276 push @disc, [ $type, $File::Find::name, l('not owned by root')] 2277 if $stat[4] != 0; 2278 push @disc, [ $type, $File::Find::name, l('world writable') ] 2279 if (07777 & $stat[2] & 02); 2280 push @disc, [ $type, $File::Find::name, l('group writable') ] 2281 if (07777 & $stat[2] & 020); 2282 }; 2283 2284 File::Find::find($wanted, $dir); 2285 return 1 if ! @disc; 2286 my $out = ""; 2287 for (@disc) { 2288 $_->[1] =~ s!^$dir/!!; 2289 $out .= errmsg(" %s %s is %s\n", @$_); 2290 } 2291 return $out; 2292} 2293 2294sub compile_link { 2295 my $cref = shift || \%Conf; 2296 for( qw/linkmode cgiurl vendroot cgidir cgiurl/) { 2297 die errmsg("improper reference passed, missing: %s", $_) 2298 if ! $cref->{$_}; 2299 } 2300 return 1 if $cref->{linkmode} =~ /^\s*n/i; 2301 my @args; 2302 my $cginame = $cref->{cgiurl}; 2303 $cginame =~ s:.*/::; 2304 $cref->{cgifile} = $cginame = "$cref->{relocate}$cref->{cgidir}/$cginame"; 2305 die errmsg("%s %s: %s", 'target file', $cref->{cgifile}, 'is a directory') 2306 if -e $cref->{cgifile}; 2307 my $exec = "$cref->{relocate}$cref->{vendroot}/bin/compile_link"; 2308 die errmsg("%s %s: %s", 'executable file', $exec, 'not executable') 2309 if ! -x $exec; 2310 push @args, ( 2311 $cref->{linkmode} =~ /^\s*u/i 2312 ? '--unixmode' 2313 : '--inetmode' 2314 ); 2315 push @args, "--source=$cref->{relocate}$cref->{vendroot}/src"; 2316 push @args, "--outputfile=$cref->{relocate}$cref->{cgifile}"; 2317 push @args, "--port=$cref->{linkport}" 2318 if $cref->{linkport}; 2319 push @args, "--host=$cref->{linkhost}" 2320 if $cref->{linkhost}; 2321 push @args, "--nosuid" 2322 if $cref->{cgiwrap}; 2323 push @args, "--nosuid" 2324 if $cref->{cgiwrap}; 2325 for (@args) { 2326 die errmsg("Improper argument: %s", $_) 2327 if /"/; 2328 $_ = qq{"$_"}; 2329 } 2330 my $dir = $ENV{TMP} || '/tmp'; 2331 my $bdir = "$dir/compile_link.$$"; 2332 my $outfile = "$bdir/build.out"; 2333 my $errfile = "$bdir/build.err"; 2334 File::Path::mkpath($bdir); 2335 push @args, "--build=$bdir"; 2336 2337 system join " ", 2338 $exec, 2339 @args, 2340 "2>$errfile", 2341 ">$outfile"; 2342 2343 if($?) { 2344 my $msg = `cat $errfile`; 2345 die errmsg("Failed to compile and copy link:\n\n%s", $msg); 2346 } 2347 File::Path::rmtree($bdir); 2348 unlink $errfile; 2349 unlink $outfile; 2350 return 1; 2351} 2352 2353my @Action; 2354 2355sub evaluate_action { 2356 my $act = shift; 2357 ref($act) eq 'HASH' or die "usage: evaluate_action(\%action)"; 2358 my $orig_dir; 2359 my $error; 2360 eval { 2361 if($act->{chdir}) { 2362 $orig_dir = cwd(); 2363 my $dir = $act->{chdir}; 2364 $dir = substitute($dir) if $dir =~ /__MVC_/; 2365 chdir $dir 2366 or die errmsg("Unable to change directory to %s.", $dir) . "\n"; 2367 } 2368 if($act->{from_dir} and $act->{to_dir}) { 2369 if($Conf{relocate}) { 2370 $act->{to_dir} = "$Conf{relocate}$act->{to_dir}"; 2371 $act->{from_dir} = "$Conf{relocate}$act->{from_dir}"; 2372 } 2373 copy_dir($act->{from_dir}, $act->{to_dir}, undef, $act); 2374 if($act->{delete_from}) { 2375 File::Path::rmtree($act->{from_dir}); 2376 } 2377 } 2378 if(my $sub = $act->{sub}) { 2379 my $args = $act->{args} || []; 2380 $sub->(@$args); 2381 } 2382 if(my $cmd = $act->{command}) { 2383 $cmd = substitute($cmd) if $cmd =~ /__MVC_/; 2384 system $cmd; 2385 if($?) { 2386 my $status = $? >> 8; 2387 die errmsg( 2388 "Command %s returned status %s: %s", 2389 $cmd, 2390 $status, 2391 $!, 2392 ) . "\n"; 2393 } 2394 } 2395 }; 2396 $error = $@ if $@; 2397 chdir $orig_dir if $orig_dir; 2398 die $error if $error; 2399 return; 2400} 2401 2402sub build_cat { 2403 my ($scale, $die, $warn, $opt) = @_; 2404debug("build_cat called scalesub=$scale"); 2405 2406 $opt ||= {}; 2407 ( 2408 $scale && ! ref $scale eq 'CODE' 2409 or 2410 $die && ! ref $die eq 'CODE' 2411 or 2412 $warn && ! ref $warn eq 'CODE' 2413 or 2414 $opt && ! ref $opt eq 'HASH' 2415 ) and die errmsg("usage: %s", 'build_cat(\&scale,\&die,\&warn,$hashref)'); 2416 2417 $die = sub { die errmsg(@_) . "\n"; } if ! $die; 2418 $warn = sub { die errmsg(@_) . "\n"; } if ! $die; 2419 2420 my $cref = $opt->{configuration} || \%Conf; 2421 2422 my @action; 2423 2424# Here we create an array of hashes. The elements: 2425# structure is: 2426# 2427# from_dir => directory to copy from (done before sub) 2428# to_dir => directory to copy to 2429# delete_from => delete from_dir when finished 2430# sub => subroutine to run 2431# args => subroutine args 2432# message => message for scale routine 2433# scale => value to be added to scale when done 2434# error => Error message if fails 2435# error_ok => Ignore error if it occurs 2436# error_warn => Issue conditional warning if error 2437# (dies if in batch mode) 2438# 2439# If "action_ref" option key is provided, it is used instead. (Unlikely 2440# ever to be used, obviously.) 2441 2442 CREATEACTION: { 2443 if($opt->{action_ref}) { 2444 @action = @{$opt->{action_ref}}; 2445 last CREATEACTION; 2446 } 2447 2448 push @action, { 2449 sub => \&substitute_cryptpw, 2450 message => errmsg('Encrypting passwords'), 2451 scale => 1, 2452 }; 2453 2454 push @action, { 2455 sub => \&compile_link, 2456 args => [ $cref ], 2457 message => errmsg('Compiling link programs'), 2458 scale => 4, 2459 }; 2460 2461 push @action, { 2462 sub => sub { 2463 hammer_symlinks("$Conf{relocate}$Conf{catroot}"), 2464 }, 2465 message => errmsg("Cleaning up catalog directory"), 2466 scale => 1, 2467 } if -d "$Conf{relocate}$Conf{catroot}"; 2468 2469 if(my $wref = $Window{precopy_commands}) { 2470 $wref->{contents} ||= []; 2471 for(@{$wref->{contents}}) { 2472 my $cref = $Content{$_}; 2473 $cref->{scale} = 1 unless defined $cref->{scale}; 2474 $cref->{message} = "Running $cref->{command}" 2475 unless $cref->{message}; 2476 $cref->{error_warn} = 1 2477 unless $cref->{error_ok}; 2478 if(! $cref->{conditional} or $cref->{conditional}->()) { 2479 push @action, $cref; 2480 } 2481 } 2482 } 2483 push @action, { 2484 from_dir => "$Conf{vendroot}/$Conf{demotype}", 2485 to_dir => $Conf{catroot}, 2486 dmode => 02770, 2487 fmode => 0660, 2488 Substitute => \%Conf, 2489 error => $Build_error{demotype}, 2490 message => errmsg("Copying base demo skeleton"), 2491 scale => 3, 2492 }; 2493 2494 push @action, { 2495 delete_from => 1, 2496 dmode => 0775, 2497 error => $Build_error{demotype}, 2498 fmode => 0664, 2499 from_dir => "$Conf{catroot}/html", 2500 message => errmsg("Copying public HTML files"), 2501 scale => 1, 2502 to_dir => $Conf{samplehtml}, 2503 }; 2504 2505 push @action, { 2506 delete_from => 1, 2507 dmode => 0775, 2508 error => $Build_error{demotype}, 2509 fmode => 0664, 2510 from_dir => "$Conf{catroot}/images", 2511 message => errmsg("Copying image files"), 2512 scale => 2, 2513 symlink_to => 1, 2514 to_dir => $Conf{imagedir}, 2515 }; 2516 2517 if(my $wref = $Window{postcopy_commands}) { 2518 $wref->{contents} ||= []; 2519 for(@{$wref->{contents}}) { 2520 my $cref = $Content{$_}; 2521 $cref->{scale} = 1 unless defined $cref->{scale}; 2522 $cref->{chdir} = $Conf{catroot} unless $cref->{chdir}; 2523 $cref->{message} = "Running $cref->{command}" 2524 unless $cref->{message}; 2525 $cref->{error_warn} = 1 2526 unless $cref->{error_ok}; 2527 if(! $cref->{conditional} or $cref->{conditional}->()) { 2528 push @action, $cref; 2529 } 2530 } 2531 } 2532 2533 push @action, { 2534 sub => \&add_catalog, 2535 message => errmsg("Adding catalog to interchange.cfg"), 2536 scale => 1, 2537 } if $cref->{add_catalog}; 2538debug("run_catalog=$cref->{run_catalog} server_running=" . server_running()); 2539 push @action, { 2540 sub => \&run_catalog, 2541 message => errmsg("Running catalog"), 2542 scale => 1, 2543 } if $cref->{run_catalog} and server_running(); 2544 } 2545 my $total_scale = 0; 2546 foreach my $act (@action) { 2547 $total_scale += $act->{scale}; 2548 } 2549 2550debug("total scale amount=$total_scale scalesub=$scale"); 2551 ## install_scale returns a closure implementing whatever scale 2552 ## there is.... 2553 my $msg = errmsg("Installing catalog: %s", $Conf{catalogname}); 2554 my $scale_call; 2555debug("scale_call=$scale_call"); 2556 if(! $opt->{event_driven}) { 2557 $scale_call = $scale->($total_scale, $msg) 2558 if $scale; 2559 foreach my $act (@action) { 2560debug("action: " . uneval($act)); 2561 $scale_call->('start', $act->{scale}, errmsg($act->{message})) 2562 if $scale_call; 2563 #select(undef,undef,undef, .75); 2564 my $orig_dir; 2565 eval { 2566 evaluate_action($act); 2567 }; 2568 if(! $@) { 2569 $scale_call->('end') 2570 if $scale_call; 2571 } 2572 elsif($act->{error_ok}) { 2573debug("action error_ok: $@"); 2574 my $msg = errmsg($act->{message}) . "..." . errmsg('failed') . "."; 2575 $scale_call->('end', undef, $msg) 2576 if $scale_call;; 2577 } 2578 elsif($act->{error_warn}) { 2579debug("action error_warn: $@"); 2580 my $msg = $@; 2581 $warn->($msg) 2582 or do { 2583 $die->($msg); 2584 return undef; 2585 }; 2586 } 2587 else { 2588debug("action fatal_error: $@"); 2589 $die->( errmsg("Error installing catalog %s: %s")); 2590 return undef; 2591 } 2592 chdir $orig_dir if $orig_dir; 2593 } 2594 $scale_call->('finish') 2595 if $scale_call; 2596 } 2597 elsif($scale) { 2598 eval { 2599 $scale->($total_scale, $msg, \&evaluate_action, @action); 2600 }; 2601 if($@) { 2602debug("action fatal_error: $@"); 2603 $die->( errmsg("Error installing catalog %s: %s")); 2604 return undef; 2605 } 2606 } 2607 else { 2608 die "Must have scale subroutine call if event-driven\n"; 2609 } 2610 2611} 2612 2613package readline; 2614 2615use vars qw/$AcceptLine/; 2616 2617sub discard_ReadKey { 2618 return unless $Term::ReadKey::VERSION; 2619 my $timeout = shift || '-1'; 2620 local($^W); 2621 eval { 2622 Term::ReadKey::ReadKey(-1, $readline::term_IN); 2623 }; 2624} 2625 2626sub F_CatchHelp { 2627 $AcceptLine = "\cY"; 2628} 2629 2630sub F_CatchCancel { 2631 $AcceptLine = "\cX"; 2632 discard_ReadKey(1); 2633} 2634 2635sub F_CatchBackward { 2636 $AcceptLine = "\cB"; 2637 discard_ReadKey(1); 2638} 2639 2640sub F_CatchForward { 2641 $AcceptLine = "\cF"; 2642 discard_ReadKey(1); 2643} 2644 26451; 2646__END__ 2647
