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 / MMutil.pm < prev    next >
Encoding:
Perl POD Document  |  2003-12-10  |  12.6 KB  |  596 lines
  1. # Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::MMutil;
  5. use ExtUtils::MakeMaker;
  6. use Cwd;
  7. use Config;
  8. use Carp;
  9. use File::Basename;
  10.  
  11. use vars qw($VERSION);
  12. $VERSION = sprintf '4.%03d', q$Revision: #20 $ =~ /\D(\d+)\s*$/;
  13.  
  14. # warn __FILE__." $VERSION\n";
  15.  
  16. use Tk::MakeDepend;
  17.  
  18. use Tk::Config qw(!$VERSION);
  19. use vars qw($IsWin32);
  20.  
  21. *IsWin32 = \$main::IsWin32;
  22. $IsWin32 = ($^O eq 'MSWin32' || $Config{'ccflags'} =~ /-D_?WIN32_?/)
  23.        unless defined $IsWin32;
  24.  
  25. @MYEXPORT = qw(pasthru perldepend cflags const_config constants installbin c_o xs_o makefile manifypods);
  26.  
  27. sub arch_prune
  28. {
  29.  my $hash = shift;
  30.  foreach (keys %$hash)
  31.   {
  32.    if ($win_arch eq 'x')
  33.     {
  34.      delete $hash->{$_} if /Win[A-Z0-9]/ or /OS2/ or /ImgUtil/ or /^x/;
  35.     }
  36.    elsif ($win_arch eq 'open32')
  37.     {
  38.      delete $hash->{$_} if /Unix|Mwm/ and not /tclUnix/;
  39.      delete $hash->{$_} if /winMain|dllMain/;
  40.     }
  41.    elsif ($win_arch eq 'pm')
  42.     {
  43.      delete $hash->{$_}
  44.        if /Unix|Mwm/ and not
  45.      /tclUnix|Unix(3d|Button|Dialog|Color|Embed|Focus|Font|Menu|Scrlbr|Send|Int\.|Scale)/;
  46.      delete $hash->{$_} if /os2Main|dllMain|tkOS2Dll|^x(colors\.c|gc\.)/;
  47.      delete $hash->{$_} if /ImgUtil|tkWin[A-Z0-9]/ and not /OS2/;
  48.     }
  49.    elsif ($win_arch eq 'MSWin32')
  50.     {
  51.      delete $hash->{$_} if /Mwm/ and not /tclUnix/;
  52.      delete $hash->{$_} if /winMain|dllMain/;
  53.      # delete $hash->{$_} if /^Xrm/;
  54.     }
  55.   }
  56. }
  57.  
  58. sub mTk_postamble
  59. {
  60.  my ($self) = @_;
  61.  my $dep = "config :: \$(C_FILES) \$(H_FILES)\n\t$self->{NOECHO}\$(NOOP)\n";
  62.  my $mTk = $self->{'MTK'};
  63.  $dep .= "# Begin Munging dependencies\n";
  64.  foreach my $file (sort keys %$mTk)
  65.   {
  66.    $dep .= "$file : ".$mTk->{$file}." \$(TKDIR)/pTk/Tcl-pTk\n";
  67.    $dep .= "\t\$(PERL) \$(TKDIR)/pTk/Tcl-pTk ".$mTk->{$file}." $file\n";
  68.   }
  69.  $dep .= "# End Munging dependencies\n\n";
  70.  return $dep;
  71. }
  72.  
  73. sub mTk_CHO
  74. {
  75.  my $self = shift;
  76.  my $mTk  = shift;
  77.  my $exc  = shift;
  78.  my %c;
  79.  my %h;
  80.  foreach (@{$self->{H}}) { $h{$_} = 1 }
  81.  foreach (@{$self->{C}}) { $c{$_} = 1 }
  82.  foreach (keys %$mTk)
  83.   {
  84.    if (/\.c$/)
  85.     {
  86.      $c{$_} = 1;
  87.     }
  88.    elsif (/\.h$/)
  89.     {
  90.      $h{$_} = 1;
  91.     }
  92.   }
  93.  foreach (keys %$exc)
  94.   {
  95.    if (/\.c$/)
  96.     {
  97.      delete $c{$_};
  98.     }
  99.    elsif (/\.h$/)
  100.     {
  101.      delete $h{$_};
  102.     }
  103.   }
  104.  while (@_)
  105.   {
  106.    my $name = shift;
  107.    cluck("No $name") unless (exists $c{$name});
  108.    delete $c{$name}
  109.   }
  110.  arch_prune(\%h);
  111.  arch_prune(\%c);
  112.  $self->{'H'}     = [sort keys %h];
  113.  $self->{'C'}     = [sort keys %c];
  114.  my(@o_files)     = @{$self->{C}};
  115.  $self->{O_FILES} = [grep s/\.c(pp|xx|c)?$/$self->{OBJ_EXT}/i, @o_files] ;
  116.  $self->{'MTK'}   = $mTk;
  117.  my $tk = installed_tk();
  118.  my $perl = $self->{'PERL'};
  119.  if ($IsWin32 && !-f $perl && -f "$perl.exe")
  120.   {
  121.    print "perl=$perl X=$^X\n";
  122.    $perl = "$perl.exe";
  123.    $self->{'PERL'} = $perl;
  124.   }
  125.  foreach my $file (sort keys %$mTk)
  126.   {
  127.    unless (-f $file && -M $file < -M $mTk->{$file})
  128.     {
  129.      warn "Extracting $file\n";
  130.      system($perl,"$tk/pTk/Tcl-pTk",$mTk->{$file},$file);
  131.     }
  132.   }
  133. }
  134.  
  135. my %visited;
  136.  
  137. sub abspath
  138. {
  139.  my $dir = shift;
  140.  my $here = getcwd() || die "Cannot get current directory:$!";
  141.  if (chdir($dir))
  142.   {
  143.    $dir = getcwd();
  144.    chdir($here) || die "Cannot cd back to $here:$!";
  145.   }
  146.  return $dir;
  147. }
  148.  
  149. sub relpath
  150. {
  151.  my ($path,$dir) = @_;
  152.  unless (defined $dir)
  153.   {
  154.    $dir = (-d $path) ? $path : dirname($path);
  155.   }
  156.  if (defined $dir and -d $dir)
  157.   {
  158.    if ($path =~ m#^\Q$dir\E([/\\]?.*)$#)
  159.     {
  160.      my $base  = $1;
  161.      my $here  = getcwd;
  162.      if ($here =~ m#^\Q$dir\E([/\\]?.*)#)
  163.       {
  164.        my $depth = reverse($1);
  165.        if ($depth)
  166.     {
  167.      $depth =~ s,[^/\\]+,..,g;
  168.     }
  169.        else
  170.     {
  171.      $depth = '.' ;
  172.     }
  173.        $depth =~ s,[/\\]+$,,;
  174.        $base =~ s,^[/\\]+,,;
  175.        $depth .= "/$base" if ($base);
  176.        if (-e $depth)
  177.     {
  178.      # print "$path is $depth from $here\n";
  179.      return $depth;
  180.     }
  181.        else
  182.     {
  183.      warn "Cannot find $depth\n";
  184.     }
  185.       }
  186.      else
  187.       {
  188.        unless(exists $visited{$here})
  189.     {
  190.      $visited{$here} = 1;
  191.      warn "$here does not start with $dir\n";
  192.      warn "i.e. building outside Tk itself\n";
  193.     }
  194.       }
  195.     }
  196.    else
  197.     {
  198.      die "'$path' not under '$dir'\n";
  199.     }
  200.   }
  201.  else
  202.   {
  203.    die "Cannot get directory for $path\n";
  204.   }
  205.  return $path;
  206. }
  207.  
  208. use strict;
  209.  
  210. sub upgrade_pic
  211. {
  212.  my $flags = '';
  213.  die 'upgrade_pic is obsolete';
  214.  return $flags;
  215. }
  216.  
  217. sub pasthru
  218. {
  219.  my $self = shift;
  220.  my $str = $self->MM::pasthru;
  221.  if ($str =~ s/^\s+INC=.*\n//m)
  222.   {
  223.    return "\n#Do NOT pasthru INC for Tk - it is computed by subdir\n".$str;
  224.   }
  225.  return $str;
  226. }
  227.  
  228. sub perldepend
  229. {
  230.  my $self = shift;
  231.  my $str = $self->MM::perldepend;
  232.  my $name;
  233.  my %c;
  234.  foreach my $file (@{$self->{'C'}})
  235.   {
  236.    $c{$file} = 1;
  237.   }
  238.  foreach my $file (keys %{$self->{'XS'}})
  239.   {
  240.    $c{$file} = 1;
  241.    delete $c{$self->{'XS'}{$file}};
  242.   }
  243.  my @files = grep(-f $_,sort(keys %c));
  244.  if (@files)
  245.   {
  246.    my $tk = installed_tk();
  247.    my @inc   = split(/\s+/,$self->{'INC'});
  248.    my @def   = split(/\s+/,$self->{'DEFINE'});
  249.    push(@def,qw(-DWIN32 -D__WIN32__)) if ($IsWin32);
  250.    if ($^O eq 'cygwin')
  251.     {
  252.      push(@def,qw(-D__CYGWIN__));
  253.      if ($win_arch eq 'MSWin32')
  254.       {
  255.        push(@def,qw(-D__WIN32__)) unless $self->{'DEFINE'} =~ /-D__WIN32__/;
  256.        push(@def,qw(-DWIN32)) if $self->{'NAME'} eq 'Tk::pTk';
  257.       }
  258.      elsif ($win_arch eq 'x')
  259.       {
  260.        push(@def,qw(-U_WIN32));
  261.       }
  262.     }
  263.    foreach (@inc)
  264.     {
  265.      s/\$\(TKDIR\)/$tk/g;
  266.      warn "Odd:$_" if /\$\(/;
  267.     }
  268.    $str .= Tk::MakeDepend::command_line(@inc,@def,@files) unless ($ENV{'TKNOMAKEDEPEND'});
  269.   }
  270.  return $str;
  271. }
  272.  
  273. sub const_config
  274. {
  275.  my $self = shift;
  276.  my $name;
  277.  foreach $name (grep /(%|\.(old|bak|q4|orig|rej))$/,keys %{$self->{PM}})
  278.   {
  279.    delete $self->{PM}->{$name};
  280.   }
  281.  my $flags = $self->{'CCCDLFLAGS'};
  282.  $flags =~ s/(-[fK]?\s*)pic\b/${1}PIC/;
  283.  $self->{'CCCDLFLAGS'} = $flags;
  284.  if ($^O eq 'MSWin32' && $Config{'ccflags'} =~ /-DPERL_OBJECT/)
  285.   {
  286.    $self->{'LDFLAGS'} =~ s/-(debug|pdb:\w+)\s+//g;
  287.    $self->{'LDDLFLAGS'} =~ s/-(debug|pdb:\w+)\s+//g;
  288.   }
  289.  elsif ($^O eq 'darwin' )
  290.   {
  291.    $self->{'LDDLFLAGS'} =~ s/-flat_namespace//;
  292.    $self->{'LDDLFLAGS'} =~ s/-undefined\s+suppress//;
  293.    if ( -e "$Config{'archlib'}/CORE/$Config{'libperl'}" ) {
  294.     $self->{'LDDLFLAGS'} .= " -L\${PERL_ARCHLIB}/CORE -lperl ";
  295.    }
  296.    elsif ( -e "/System/Library/Perl/darwin/CORE/libperl.dylib" ) {
  297.     $self->{'LDDLFLAGS'} .= " -L/System/Library/Perl/darwin/CORE -lperl ";
  298.    }
  299.    else {
  300.     warn "Can't find libperl.dylib";
  301.    }
  302.    $self->{'LDFLAGS'} =~ s/-flat_namespace//;
  303.    $self->{'LDFLAGS'} =~ s/-undefined\s+suppress//;
  304.   } elsif ($^O =~ /(openbsd)/i)
  305.   {
  306.    # -Bforcearchive is bad news for Tk - we don't want all of libpTk.a in all .so-s.
  307.    $self->{'LDDLFLAGS'} =~ s/-Bforcearchive\s*//g;
  308.   }
  309.  return $self->MM::const_config;
  310. }
  311.  
  312. sub constants
  313. {
  314.  my $self = shift;
  315.  local $_ = $self->MM::constants;
  316.  s/(\.SUFFIXES)/$1:\n$1/;
  317.  $_ .= "\nGCCOPT = $Tk::Config::gccopt\n";
  318.  if ($IsWin32)
  319.   {
  320.   }
  321.  $_;
  322. }
  323.  
  324. sub cflags
  325. {
  326.  my $self = shift;
  327.  local $_ = $self->MM::cflags;
  328.  if (0 && $IsWin32)
  329.   {
  330.    if ($Config::Config{cc} =~ /^bcc/i) {
  331.      # s/(CCFLAGS\s*=)/$1/;
  332.    }
  333.    else {
  334.      s/(CCFLAGS\s*=)/$1 \$(cflags) \$(cvarsdll)/;
  335.      s/(OPTIMIZE\s*=).*/$1 \$(cdebug)/;
  336.    }
  337.   }
  338.  $_;
  339. }
  340.  
  341. sub c_o
  342. {
  343.  my $self = shift;
  344.  local $_ = $self->MM::c_o;
  345.  s/\$\(DEFINE\)/\$(DEFINE) \$(GCCOPT)/g;
  346.  $_;
  347. }
  348.  
  349. sub xs_o
  350. {
  351.  my $self = shift;
  352.  local $_ = $self->MM::xs_o;
  353.  s/\$\(DEFINE\)/\$(DEFINE) \$(GCCOPT)/g;
  354.  $_;
  355. }
  356.  
  357. sub manifypods
  358. {
  359.  my $self = shift;
  360.  # Maybe always call UNIX version - we HTMLize them later
  361.  local $_ = $self->MM::manifypods;
  362.  if ($] >= 5.00565)
  363.   {
  364.    s/(POD2MAN_EXE.*pod2man.*)/$1 --center "perl\/Tk Documentation" --release "Tk\$(VERSION)"/;
  365.   }
  366.  elsif ($] >= 5.003)
  367.   {
  368.    s/(POD2MAN_EXE.*pod2man.*)/$1 -center "perl\/Tk Documentation" -release "Tk\$(VERSION)"/;
  369.   }
  370.  else
  371.   {
  372.    s/(POD2MAN_EXE.*pod2man.*)/$1 -center \\"perl\/Tk Documentation\\" -release \\"Tk\$(VERSION)\\"/;
  373.   }
  374.  s/\bpod::/Tk::/mg;
  375.  s/\bpTk:://mg;
  376.  $_;
  377. }
  378.  
  379. sub findINC
  380. {
  381.  my $file = shift;
  382.  my $dir;
  383.  foreach $dir (@INC)
  384.   {
  385.    my $try = "$dir/$file";
  386.    return $try if (-f $try);
  387.   }
  388.  die "Cannot find $file in \@INC\n";
  389. }
  390.  
  391.  
  392. sub makefile
  393. {
  394.  my $self = shift;
  395.  my $str  = $self->MM::makefile;
  396.  my $mm = findINC('Tk/MMutil.pm');
  397.  my $cf = findINC('Tk/Config.pm');
  398.  $str =~ s/(\$\(CONFIGDEP\))/$1 $cf $mm/;
  399.  $str =~ s/\$\(OBJECT\)\s*:.*\n//;
  400.  return $str;
  401. }
  402.  
  403. sub installed_tk
  404. {
  405.  my $tk;
  406.  my $dir;
  407.  foreach $dir (@INC)
  408.   {
  409.    if (-f "$dir/tkGlue.h")
  410.     {
  411.      $tk = relpath($dir);
  412.      last;
  413.     }
  414.    my $try = "$dir/Tk";
  415.    if (-f "$try/tkGlue.h")
  416.     {
  417.      $tk = relpath($try,$dir);
  418.      last;
  419.     }
  420.   }
  421.  die "Cannot find perl/Tk include files\n" unless (defined $tk);
  422.  $tk =~ s,^(\./)+,,;
  423.  return $tk;
  424. }
  425.  
  426. sub installbin
  427. {
  428.  my ($self) = @_;
  429.  my $str  = $self->MM::installbin;
  430.  my $prog = 'perl'; # $self->{'MAP_TARGET'} || 'perl';
  431.  my $inc  = findINC('Tk/MMutil.pm');
  432.  $inc =~ s,/Tk/MMutil.pm$,,;
  433.  $inc = relpath($inc);
  434.  $str =~ s/^\tcp\s/\t\$(PERL) -I$inc -MTk::install -e installbin $prog /mg;
  435.  return $str;
  436. }
  437.  
  438. sub findpTk
  439. {
  440.  my $ptk;
  441.  my $dir;
  442.  foreach $dir (map(abspath($_),@_),@INC)
  443.   {
  444.    my $try = "$dir/pTk";
  445.    if (-d $try && (-f "$try/Lang.h" || -f "$try/libpTk\$(LIB_EXT)"))
  446.     {
  447.      $ptk = relpath($try,$dir);
  448.      last;
  449.     }
  450.   }
  451.  confess "Cannot locate pTk\n" unless (defined $ptk);
  452.  return $ptk;
  453. }
  454.  
  455. sub find_subdir
  456. {
  457.  my %dir;
  458.  opendir(DIR,'.') || die "Cannot opendir:$!";
  459.  foreach my $dir (readdir(DIR))
  460.   {
  461.    next if $dir =~ /^\.\.?$/;
  462.    next if -l $dir;
  463.    next unless -d $dir;
  464.    if (-f "$dir/Makefile.PL")
  465.     {
  466.      my $exc = ($win_arch eq 'x') ? 'Unix' : 'Win';
  467.      if (-f "$dir/Not${exc}.exc")
  468.       {
  469.        warn "Skip $dir on $win_arch\n"
  470.       }
  471.      else
  472.       {
  473.        $dir{$dir} = 1
  474.       }
  475.     }
  476.   }
  477.  closedir(DIR);
  478.  return \%dir;
  479. }
  480.  
  481. sub TkExtMakefile
  482. {
  483.  my (%att) = @_;
  484.  if ($Config{'ccflags'} =~ /-DPERL_OBJECT/)
  485.   {
  486.    $att{'CAPI'} = 'TRUE' unless exists $att{'CAPI'};
  487.   }
  488.  unless (exists $att{'DIR'})
  489.   {
  490.    my $dir = find_subdir();
  491.    $att{'DIR'} = [sort(keys %$dir)];
  492.   }
  493.  unless (exists $att{'NAME'})
  494.   {
  495.    my $dir = getcwd;
  496.    my ($pack) = $dir =~ m#/([^/]+)$#;
  497.    if (defined $pack)
  498.     {
  499.      $att{NAME} = 'Tk::'.$pack;
  500.     }
  501.    else
  502.     {
  503.      warn "No Name and cannot deduce from '$dir'";
  504.     }
  505.   }
  506.  my $tk = installed_tk();
  507.  $att{'macro'} = {} unless (exists $att{'macro'});
  508.  $att{'macro'}{'TKDIR'} = $tk;
  509.  my @opt = ('VERSION'     => $Tk::Config::VERSION,
  510.         'XS_VERSION'  => $Tk::Config::VERSION);
  511.  push(@opt,'clean' => {} ) unless (exists $att{'clean'});
  512.  $att{'clean'}->{FILES} = '' unless (exists $att{'clean'}->{FILES});
  513.  $att{'clean'}->{FILES} .= ' *.bak';
  514.  unless (exists($att{'linkext'}) && $att{linkext}{LINKTYPE} eq '')
  515.   {
  516.    my $ptk = findpTk($tk);
  517.    my @tm = (findINC('Tk/typemap'));
  518.    unshift(@tm,@{$att{'TYPEMAPS'}}) if (exists $att{'TYPEMAPS'});
  519.    $att{'TYPEMAPS'} = \@tm;
  520.    my $i = delete ($att{'INC'});
  521.    $i = (defined $i) ? "$i $inc" : $inc;
  522.    if (delete $att{'dynamic_ptk'})
  523.     {
  524.      push(@opt,
  525.       'MYEXTLIB' => "$ptk/libpTk\$(LIB_EXT)",
  526. #         'dynamic_lib' => { INST_DYNAMIC_DEP => "$ptk/libpTk\$(LIB_EXT)" }
  527.      );
  528.     }
  529.    # Several loadable widgets use things from -lm
  530.    # if platform does not have a shared -lm need to link against it
  531.    if ($Config{libs} =~/-lm\b/)
  532.     {
  533.      my $libs = $att{'LIBS'}->[0];
  534.      $att{'LIBS'}->[0] = "$libs -lm" unless $libs =~ /-lm\b/;
  535.     }
  536.    if ($IsWin32 && $Config{'cc'} =~ /^bcc/)
  537.     {
  538.      # Borland compiler is very dumb at finding files
  539.      $i = "-I$tk $i";
  540.      $i = "-I$ptk $i";
  541.     }
  542.    if ($IsWin32 && $Config{'cc'} =~ /^gcc/i)
  543.     {
  544.      my $base  = $Config{'libpth'};
  545.      $base =~ s#lib$#i386-mingw32/lib#;
  546.      my $extra = "-L$base -lcomdlg32 -lgdi32";
  547.      my $libs = $att{'LIBS'}->[0];
  548.      $att{'LIBS'}->[0] = "$extra $libs";
  549.     }
  550.    if ($^O eq 'cygwin')
  551.     {
  552.      # NOTE: use gcc -shared instead of dllwrap (ld2),
  553.      # dllwrap tries to resolve all symbols, even those
  554.      # that are brought in from libraries like libpTk.a
  555.      push(@opt,'LD' => 'gcc -shared');
  556.      if ($win_arch eq 'MSWin32')
  557.       {
  558.        my $extra = "-L/lib/w32api -lcomdlg32 -lgdi32";
  559.        my $libs = $att{'LIBS'}->[0];
  560.        $att{'LIBS'}->[0] = "$extra $libs";
  561.        $att{'DEFINE'} .= ' -D__WIN32__ -D_WIN32';
  562.        $att{'DEFINE'} .= ' -DWIN32' if($att{'NAME'} eq 'Tk::pTk');
  563.       }
  564.      elsif ($win_arch eq 'x')
  565.       {
  566.        $att{'DEFINE'} .= ' -U_WIN32';
  567.       }
  568.     }
  569.    if (delete $att{'ptk_include'})
  570.     {
  571.      $i = "-I$ptk $i" unless ($ptk eq '.');
  572.     }
  573.    else
  574.     {
  575.      $i = "-I$tk $i" unless ($tk eq '.');
  576.     }
  577.    push(@opt,'DEFINE' => $define, 'INC' => $i);
  578.   }
  579.  WriteMakefile(@opt, %att);
  580. }
  581.  
  582. sub import
  583. {
  584.  no strict 'refs';
  585.  my $class = shift;
  586.  my @list = (@_) ? @_ : @{"${class}::MYEXPORT"};
  587.  my $name;
  588.  foreach $name (@list)
  589.   {
  590.    *{"MY::$name"} = \&{"$name"};
  591.   }
  592. }
  593.  
  594.  
  595. 1;
  596.