home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _f9e2db32ec02c4e467a369c92e15c39a < prev    next >
Encoding:
Text File  |  2004-06-01  |  13.3 KB  |  601 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: #21 $ =~ /\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.    $str = "# - Do NOT pasthru INC for Tk - it is computed by subdir\n$str"
  224.   }
  225.  if ($str =~ s/\bLIB="\$\(LIB\)"//)
  226.   {
  227.    $str = qq[# - Drop LIB="\$(LIB)" - not used\n$str];
  228.   }
  229.  $str = "#Tk::MMutil pasthru\n$str";
  230.  return $str;
  231. }
  232.  
  233. sub perldepend
  234. {
  235.  my $self = shift;
  236.  my $str = $self->MM::perldepend;
  237.  my $name;
  238.  my %c;
  239.  foreach my $file (@{$self->{'C'}})
  240.   {
  241.    $c{$file} = 1;
  242.   }
  243.  foreach my $file (keys %{$self->{'XS'}})
  244.   {
  245.    $c{$file} = 1;
  246.    delete $c{$self->{'XS'}{$file}};
  247.   }
  248.  my @files = grep(-f $_,sort(keys %c));
  249.  if (@files)
  250.   {
  251.    my $tk = installed_tk();
  252.    my @inc   = split(/\s+/,$self->{'INC'});
  253.    my @def   = split(/\s+/,$self->{'DEFINE'});
  254.    push(@def,qw(-DWIN32 -D__WIN32__)) if ($IsWin32);
  255.    if ($^O eq 'cygwin')
  256.     {
  257.      push(@def,qw(-D__CYGWIN__));
  258.      if ($win_arch eq 'MSWin32')
  259.       {
  260.        push(@def,qw(-D__WIN32__)) unless $self->{'DEFINE'} =~ /-D__WIN32__/;
  261.        push(@def,qw(-DWIN32)) if $self->{'NAME'} eq 'Tk::pTk';
  262.       }
  263.      elsif ($win_arch eq 'x')
  264.       {
  265.        push(@def,qw(-U_WIN32));
  266.       }
  267.     }
  268.    foreach (@inc)
  269.     {
  270.      s/\$\(TKDIR\)/$tk/g;
  271.      warn "Odd:$_" if /\$\(/;
  272.     }
  273.    $str .= Tk::MakeDepend::command_line(@inc,@def,@files) unless ($ENV{'TKNOMAKEDEPEND'});
  274.   }
  275.  return $str;
  276. }
  277.  
  278. sub const_config
  279. {
  280.  my $self = shift;
  281.  my $name;
  282.  foreach $name (grep /(%|\.(old|bak|q4|orig|rej))$/,keys %{$self->{PM}})
  283.   {
  284.    delete $self->{PM}->{$name};
  285.   }
  286.  my $flags = $self->{'CCCDLFLAGS'};
  287.  $flags =~ s/(-[fK]?\s*)pic\b/${1}PIC/;
  288.  $self->{'CCCDLFLAGS'} = $flags;
  289.  if ($^O eq 'MSWin32' && $Config{'ccflags'} =~ /-DPERL_OBJECT/)
  290.   {
  291.    $self->{'LDFLAGS'} =~ s/-(debug|pdb:\w+)\s+//g;
  292.    $self->{'LDDLFLAGS'} =~ s/-(debug|pdb:\w+)\s+//g;
  293.   }
  294.  elsif ($^O eq 'darwin' )
  295.   {
  296.    $self->{'LDDLFLAGS'} =~ s/-flat_namespace//;
  297.    $self->{'LDDLFLAGS'} =~ s/-undefined\s+suppress//;
  298.    if ( -e "$Config{'archlib'}/CORE/$Config{'libperl'}" ) {
  299.     $self->{'LDDLFLAGS'} .= " -L\${PERL_ARCHLIB}/CORE -lperl ";
  300.    }
  301.    elsif ( -e "/System/Library/Perl/darwin/CORE/libperl.dylib" ) {
  302.     $self->{'LDDLFLAGS'} .= " -L/System/Library/Perl/darwin/CORE -lperl ";
  303.    }
  304.    else {
  305.     warn "Can't find libperl.dylib";
  306.    }
  307.    $self->{'LDFLAGS'} =~ s/-flat_namespace//;
  308.    $self->{'LDFLAGS'} =~ s/-undefined\s+suppress//;
  309.   } elsif ($^O =~ /(openbsd)/i)
  310.   {
  311.    # -Bforcearchive is bad news for Tk - we don't want all of libpTk.a in all .so-s.
  312.    $self->{'LDDLFLAGS'} =~ s/-Bforcearchive\s*//g;
  313.   }
  314.  return $self->MM::const_config;
  315. }
  316.  
  317. sub constants
  318. {
  319.  my $self = shift;
  320.  local $_ = $self->MM::constants;
  321.  s/(\.SUFFIXES)/$1:\n$1/;
  322.  $_ .= "\nGCCOPT = $Tk::Config::gccopt\n";
  323.  if ($IsWin32)
  324.   {
  325.   }
  326.  $_;
  327. }
  328.  
  329. sub cflags
  330. {
  331.  my $self = shift;
  332.  local $_ = $self->MM::cflags;
  333.  if (0 && $IsWin32)
  334.   {
  335.    if ($Config::Config{cc} =~ /^bcc/i) {
  336.      # s/(CCFLAGS\s*=)/$1/;
  337.    }
  338.    else {
  339.      s/(CCFLAGS\s*=)/$1 \$(cflags) \$(cvarsdll)/;
  340.      s/(OPTIMIZE\s*=).*/$1 \$(cdebug)/;
  341.    }
  342.   }
  343.  $_;
  344. }
  345.  
  346. sub c_o
  347. {
  348.  my $self = shift;
  349.  local $_ = $self->MM::c_o;
  350.  s/\$\(DEFINE\)/\$(DEFINE) \$(GCCOPT)/g;
  351.  $_;
  352. }
  353.  
  354. sub xs_o
  355. {
  356.  my $self = shift;
  357.  local $_ = $self->MM::xs_o;
  358.  s/\$\(DEFINE\)/\$(DEFINE) \$(GCCOPT)/g;
  359.  $_;
  360. }
  361.  
  362. sub manifypods
  363. {
  364.  my $self = shift;
  365.  # Maybe always call UNIX version - we HTMLize them later
  366.  local $_ = $self->MM::manifypods;
  367.  if ($] >= 5.00565)
  368.   {
  369.    s/(POD2MAN_EXE.*pod2man.*)/$1 --center "perl\/Tk Documentation" --release "Tk\$(VERSION)"/;
  370.   }
  371.  elsif ($] >= 5.003)
  372.   {
  373.    s/(POD2MAN_EXE.*pod2man.*)/$1 -center "perl\/Tk Documentation" -release "Tk\$(VERSION)"/;
  374.   }
  375.  else
  376.   {
  377.    s/(POD2MAN_EXE.*pod2man.*)/$1 -center \\"perl\/Tk Documentation\\" -release \\"Tk\$(VERSION)\\"/;
  378.   }
  379.  s/\bpod::/Tk::/mg;
  380.  s/\bpTk:://mg;
  381.  $_;
  382. }
  383.  
  384. sub findINC
  385. {
  386.  my $file = shift;
  387.  my $dir;
  388.  foreach $dir (@INC)
  389.   {
  390.    my $try = "$dir/$file";
  391.    return $try if (-f $try);
  392.   }
  393.  die "Cannot find $file in \@INC\n";
  394. }
  395.  
  396.  
  397. sub makefile
  398. {
  399.  my $self = shift;
  400.  my $str  = $self->MM::makefile;
  401.  my $mm = findINC('Tk/MMutil.pm');
  402.  my $cf = findINC('Tk/Config.pm');
  403.  $str =~ s/(\$\(CONFIGDEP\))/$1 $cf $mm/;
  404.  $str =~ s/\$\(OBJECT\)\s*:.*\n//;
  405.  return $str;
  406. }
  407.  
  408. sub installed_tk
  409. {
  410.  my $tk;
  411.  my $dir;
  412.  foreach $dir (@INC)
  413.   {
  414.    if (-f "$dir/tkGlue.h")
  415.     {
  416.      $tk = relpath($dir);
  417.      last;
  418.     }
  419.    my $try = "$dir/Tk";
  420.    if (-f "$try/tkGlue.h")
  421.     {
  422.      $tk = relpath($try,$dir);
  423.      last;
  424.     }
  425.   }
  426.  die "Cannot find perl/Tk include files\n" unless (defined $tk);
  427.  $tk =~ s,^(\./)+,,;
  428.  return $tk;
  429. }
  430.  
  431. sub installbin
  432. {
  433.  my ($self) = @_;
  434.  my $str  = $self->MM::installbin;
  435.  my $prog = 'perl'; # $self->{'MAP_TARGET'} || 'perl';
  436.  my $inc  = findINC('Tk/MMutil.pm');
  437.  $inc =~ s,/Tk/MMutil.pm$,,;
  438.  $inc = relpath($inc);
  439.  $str =~ s/^\tcp\s/\t\$(PERL) -I$inc -MTk::install -e installbin $prog /mg;
  440.  return $str;
  441. }
  442.  
  443. sub findpTk
  444. {
  445.  my $ptk;
  446.  my $dir;
  447.  foreach $dir (map(abspath($_),@_),@INC)
  448.   {
  449.    my $try = "$dir/pTk";
  450.    if (-d $try && (-f "$try/Lang.h" || -f "$try/libpTk\$(LIB_EXT)"))
  451.     {
  452.      $ptk = relpath($try,$dir);
  453.      last;
  454.     }
  455.   }
  456.  confess "Cannot locate pTk\n" unless (defined $ptk);
  457.  return $ptk;
  458. }
  459.  
  460. sub find_subdir
  461. {
  462.  my %dir;
  463.  opendir(DIR,'.') || die "Cannot opendir:$!";
  464.  foreach my $dir (readdir(DIR))
  465.   {
  466.    next if $dir =~ /^\.\.?$/;
  467.    next if -l $dir;
  468.    next unless -d $dir;
  469.    if (-f "$dir/Makefile.PL")
  470.     {
  471.      my $exc = ($win_arch eq 'x') ? 'Unix' : 'Win';
  472.      if (-f "$dir/Not${exc}.exc")
  473.       {
  474.        warn "Skip $dir on $win_arch\n"
  475.       }
  476.      else
  477.       {
  478.        $dir{$dir} = 1
  479.       }
  480.     }
  481.   }
  482.  closedir(DIR);
  483.  return \%dir;
  484. }
  485.  
  486. sub TkExtMakefile
  487. {
  488.  my (%att) = @_;
  489.  if ($Config{'ccflags'} =~ /-DPERL_OBJECT/)
  490.   {
  491.    $att{'CAPI'} = 'TRUE' unless exists $att{'CAPI'};
  492.   }
  493.  unless (exists $att{'DIR'})
  494.   {
  495.    my $dir = find_subdir();
  496.    $att{'DIR'} = [sort(keys %$dir)];
  497.   }
  498.  unless (exists $att{'NAME'})
  499.   {
  500.    my $dir = getcwd;
  501.    my ($pack) = $dir =~ m#/([^/]+)$#;
  502.    if (defined $pack)
  503.     {
  504.      $att{NAME} = 'Tk::'.$pack;
  505.     }
  506.    else
  507.     {
  508.      warn "No Name and cannot deduce from '$dir'";
  509.     }
  510.   }
  511.  my $tk = installed_tk();
  512.  $att{'macro'} = {} unless (exists $att{'macro'});
  513.  $att{'macro'}{'TKDIR'} = $tk;
  514.  my @opt = ('VERSION'     => $Tk::Config::VERSION,
  515.         'XS_VERSION'  => $Tk::Config::VERSION);
  516.  push(@opt,'clean' => {} ) unless (exists $att{'clean'});
  517.  $att{'clean'}->{FILES} = '' unless (exists $att{'clean'}->{FILES});
  518.  $att{'clean'}->{FILES} .= ' *.bak';
  519.  unless (exists($att{'linkext'}) && $att{linkext}{LINKTYPE} eq '')
  520.   {
  521.    my $ptk = findpTk($tk);
  522.    my @tm = (findINC('Tk/typemap'));
  523.    unshift(@tm,@{$att{'TYPEMAPS'}}) if (exists $att{'TYPEMAPS'});
  524.    $att{'TYPEMAPS'} = \@tm;
  525.    my $i = delete ($att{'INC'});
  526.    $i = (defined $i) ? "$i $inc" : $inc;
  527.    if (delete $att{'dynamic_ptk'})
  528.     {
  529.      push(@opt,
  530.       'MYEXTLIB' => "$ptk/libpTk\$(LIB_EXT)",
  531. #         'dynamic_lib' => { INST_DYNAMIC_DEP => "$ptk/libpTk\$(LIB_EXT)" }
  532.      );
  533.     }
  534.    # Several loadable widgets use things from -lm
  535.    # if platform does not have a shared -lm need to link against it
  536.    if ($Config{libs} =~/-lm\b/)
  537.     {
  538.      my $libs = $att{'LIBS'}->[0];
  539.      $att{'LIBS'}->[0] = "$libs -lm" unless $libs =~ /-lm\b/;
  540.     }
  541.    if ($IsWin32 && $Config{'cc'} =~ /^bcc/)
  542.     {
  543.      # Borland compiler is very dumb at finding files
  544.      $i = "-I$tk $i";
  545.      $i = "-I$ptk $i";
  546.     }
  547.    if ($IsWin32 && $Config{'cc'} =~ /^gcc/i)
  548.     {
  549.      my $base  = $Config{'libpth'};
  550.      $base =~ s#lib$#i386-mingw32/lib#;
  551.      my $extra = "-L$base -lcomdlg32 -lgdi32";
  552.      my $libs = $att{'LIBS'}->[0];
  553.      $att{'LIBS'}->[0] = "$extra $libs";
  554.     }
  555.    if ($^O eq 'cygwin')
  556.     {
  557.      # NOTE: use gcc -shared instead of dllwrap (ld2),
  558.      # dllwrap tries to resolve all symbols, even those
  559.      # that are brought in from libraries like libpTk.a
  560.      push(@opt,'LD' => 'gcc -shared');
  561.      if ($win_arch eq 'MSWin32')
  562.       {
  563.        my $extra = "-L/lib/w32api -lcomdlg32 -lgdi32";
  564.        my $libs = $att{'LIBS'}->[0];
  565.        $att{'LIBS'}->[0] = "$extra $libs";
  566.        $att{'DEFINE'} .= ' -D__WIN32__ -D_WIN32';
  567.        $att{'DEFINE'} .= ' -DWIN32' if($att{'NAME'} eq 'Tk::pTk');
  568.       }
  569.      elsif ($win_arch eq 'x')
  570.       {
  571.        $att{'DEFINE'} .= ' -U_WIN32';
  572.       }
  573.     }
  574.    if (delete $att{'ptk_include'})
  575.     {
  576.      $i = "-I$ptk $i" unless ($ptk eq '.');
  577.     }
  578.    else
  579.     {
  580.      $i = "-I$tk $i" unless ($tk eq '.');
  581.     }
  582.    push(@opt,'DEFINE' => $define, 'INC' => $i);
  583.   }
  584.  WriteMakefile(@opt, %att);
  585. }
  586.  
  587. sub import
  588. {
  589.  no strict 'refs';
  590.  my $class = shift;
  591.  my @list = (@_) ? @_ : @{"${class}::MYEXPORT"};
  592.  my $name;
  593.  foreach $name (@list)
  594.   {
  595.    *{"MY::$name"} = \&{"$name"};
  596.   }
  597. }
  598.  
  599.  
  600. 1;
  601.