home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / MMutil.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  8.1 KB  |  407 lines
  1. # Copyright (c) 1995-1997 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 Tk::Config;
  10. @MYEXPORT = qw(perldepend cflags const_config constants installbin c_o xs_o makefile manifypods);
  11.  
  12. sub arch_prune
  13. {
  14.  my $hash = shift;
  15.  foreach (keys %$hash)
  16.   {
  17.    if ($win_arch eq 'x') 
  18.     {
  19.      delete $hash->{$_} if /Win[A-Z0-9]/ or /OS2/ or /ImgUtil/ or /^x/;
  20.     } 
  21.    elsif ($win_arch eq 'open32') 
  22.     {
  23.      delete $hash->{$_} if /Unix|Mwm/ and not /tclUnix/;
  24.      delete $hash->{$_} if /winMain|dllMain/;
  25.     }
  26.    elsif ($win_arch eq 'pm') 
  27.     {
  28.      delete $hash->{$_} if /Unix|Mwm/ and not /tclUnix/;
  29.      delete $hash->{$_} if /os2Main|dllMain|tkOS2Dll|^xgc\./;
  30.      delete $hash->{$_} if /ImgUtil|tkWin[A-Z0-9]/ and not /OS2/;
  31.     }
  32.    elsif ($win_arch eq 'MSWin32') 
  33.     {
  34.      delete $hash->{$_} if /Unix|Mwm/ and not /tclUnix/;
  35.      delete $hash->{$_} if /winMain|dllMain/;
  36.      # delete $hash->{$_} if /^Xrm/;
  37.     }
  38.   } 
  39. }
  40.  
  41. sub mTk_postamble
  42. {
  43.  my ($self) = @_;
  44.  my $dep = "config :: \$(C_FILES) \$(H_FILES)\n\t$self->{NOECHO}\$(NOOP)\n";
  45.  my $mTk = $self->{'MTK'};
  46.  $dep .= "# Begin Munging dependancies\n";
  47.  my $file;
  48.  foreach $file (sort keys %$mTk)
  49.   {
  50.    $dep .= "$file : ".$mTk->{$file}." \$(TKDIR)/pTk/Tcl-pTk\n";
  51.    $dep .= "\t\$(PERL) \$(TKDIR)/pTk/Tcl-pTk ".$mTk->{$file}." $file\n";
  52.   }
  53.  $dep .= "# End Munging dependancies\n\n";
  54.  return $dep;
  55. }
  56.  
  57. sub mTk_CHO
  58. {
  59.  my $self = shift;
  60.  my $mTk  = shift;
  61.  my %c;
  62.  my %h;
  63.  foreach (@{$self->{H}}) { $h{$_} = 1 }
  64.  foreach (@{$self->{C}}) { $c{$_} = 1 }
  65.  foreach (keys %$mTk)
  66.   {
  67.    if (/\.c$/)
  68.     {
  69.      $c{$_} = 1;
  70.     }
  71.    elsif (/\.h$/)
  72.     {
  73.      $h{$_} = 1;
  74.     }
  75.   }
  76.  while (@_)
  77.   {
  78.    my $name = shift;
  79.    carp("No $name") unless (exists $c{$name});
  80.    delete $c{$name}
  81.   }
  82.  arch_prune(\%h);
  83.  arch_prune(\%c);
  84.  $self->{'H'}     = [sort keys %h];
  85.  $self->{'C'}     = [sort keys %c];
  86.  my(@o_files)     = @{$self->{C}};
  87.  $self->{O_FILES} = [grep s/\.c(pp|xx|c)?$/$self->{OBJ_EXT}/i, @o_files] ;
  88.  $self->{'MTK'}   = $mTk;
  89. }
  90.  
  91. sub relpath
  92. {
  93.  my ($path) = @_;
  94.  if (defined $dir)
  95.   {
  96.    if ($path =~ m#^$dir\b(.*)$#)
  97.     {
  98.      my $base  = $1;
  99.      my $here  = getcwd;
  100.      if ($here =~ m#^$dir\b(.*)#)
  101.       {
  102.        my $depth = reverse($1);
  103.        if ($depth)
  104.         {
  105.          $depth =~ s,[^/\\]+,..,g;
  106.         }
  107.        else
  108.         {
  109.          $depth = '.' ;
  110.         }
  111.        $depth =~ s,[/\\]+$,,;
  112.        $base =~ s,^[/\\]+,,;
  113.        $depth .= "/$base" if ($base);
  114.        if (-e $depth)
  115.         {
  116.          # print "$path is $depth from $here\n";
  117.          return $depth;
  118.         }
  119.       }
  120.     }
  121.   }
  122.  else
  123.   {
  124.    warn "No directory defined";
  125.   }
  126.  return $path;
  127. }
  128.  
  129. use strict;
  130.  
  131. sub upgrade_pic
  132. {
  133.  my $flags = "";
  134.  die "upgrade_pic is obsolete";
  135.  return $flags;
  136. }
  137.  
  138. sub perldepend
  139. {
  140.  my $self = shift;
  141.  my $str = $self->MM::perldepend;
  142.  my $name;
  143.  my @files;
  144.  $str .= "# Auto generated from GCC's .d files\n";
  145.  foreach $name ($self->lsdir("."))
  146.   {
  147.    if ($name =~ /\.d$/)
  148.     {
  149.      local $_;
  150.      open(DEP,"<$name") || die "Cannot open $name:$!";
  151.      while (<DEP>)
  152.       {
  153.        if ($^O eq 'MSWin32')
  154.         {
  155.          s/Unix/Win/g;
  156.         }
  157.        elsif ($win_arch eq 'open32') {
  158.          s/tixUnix/tixWin/g;
  159.          s/\btkWinInt\.h\b/tkWinInt.h windows.h/g;
  160.        }
  161.        elsif ($win_arch eq 'pm') {
  162.          s/tixUnix/tixWin/g;
  163.          s/tkUnix/tkOS2/g;
  164.        }
  165.        s/^([^:]*)\.o\s*:/$1$self->{OBJ_EXT}:/;
  166.        $str .= $_;
  167.       }
  168.      close(DEP);
  169.     }
  170.   }
  171.  return $str;
  172. }
  173.  
  174. sub const_config
  175. {
  176.  my $self = shift;
  177.  my $name;
  178.  foreach $name (grep /%$/,keys %{$self->{PM}})
  179.   {
  180.    delete $self->{PM}->{$name};
  181.   }
  182.  my $flags = $self->{'CCCDLFLAGS'};
  183.  $flags =~ s/(-[fK]?\s*)pic\b/${1}PIC/; 
  184.  $self->{'CCCDLFLAGS'} = $flags;
  185.  return $self->MM::const_config;
  186. }
  187.  
  188. sub constants
  189. {
  190.  my $self = shift;
  191.  local $_ = $self->MM::constants;
  192.  s/(\.SUFFIXES)/$1:\n$1/;
  193.  if ($^O eq 'MSWin32')
  194.   {
  195.    if ($Config::Config{cc} =~ /^bcc/i) {
  196.      $_ .= "LDDLFLAGS = -Tpd\n";
  197.    }
  198.    else {
  199.      $_ .= "!include <win32.mak>\n";
  200.      $_ .= "LDLOADLIBS=\$(guilibsdll)\n";
  201.      $_ .= "LDDLFLAGS=\$(linkdebug) \$(dlllflags)\n";
  202.      $_ .= "\nGCCOPT = -WX\n";
  203.    }
  204.   } 
  205.  else
  206.   {
  207.    $_ .= "\nGCCOPT = $Tk::Config::gccopt\n";
  208.   }
  209.  $_;
  210. }
  211.  
  212. sub cflags
  213. {
  214.  my $self = shift;
  215.  local $_ = $self->MM::cflags;
  216.  if ($^O eq 'MSWin32')
  217.   {
  218.    if ($Config::Config{cc} =~ /^bcc/i) {
  219.      s/(CCFLAGS\s*=)/$1 -O -w- -I. -I.\\pTk -I.. -I..\\pTk/; 
  220.    }
  221.    else {
  222.      s/(CCFLAGS\s*=)/$1 \$(cflags) \$(cvarsdll)/; 
  223.      s/(OPTIMIZE\s*=).*/$1 \$(cdebug)/;
  224.    }
  225.   }
  226.  $_;
  227. }
  228.  
  229. sub c_o
  230. {
  231.  my $self = shift;
  232.  local $_ = $self->MM::c_o;
  233.  s/\$\(DEFINE\)/\$(DEFINE) \$(GCCOPT)/g;
  234.  $_;
  235. }
  236.  
  237. sub xs_o
  238. {
  239.  my $self = shift;
  240.  local $_ = $self->MM::xs_o;
  241.  s/\$\(DEFINE\)/\$(DEFINE) \$(GCCOPT)/g;
  242.  $_;
  243. }
  244.  
  245. sub manifypods
  246. {
  247.  my $self = shift;
  248.  # Maybe always call UNIX version - we HTMLize them later
  249.  local $_ = $self->MM::manifypods;
  250.  if ($] >= 5.003)
  251.   {
  252.    s/(POD2MAN_EXE.*pod2man)/$1 -center "perl\/Tk Documentation" -release "Tk\$(VERSION)"/;
  253.   }
  254.  else
  255.   {
  256.    s/(POD2MAN_EXE.*pod2man)/$1 -center \\"perl\/Tk Documentation\\" -release \\"Tk\$(VERSION)\\"/;
  257.   }
  258.  $_;
  259. }
  260.  
  261. sub findINC
  262. {
  263.  my $file = shift;
  264.  my $dir;
  265.  foreach $dir (@INC)
  266.   {
  267.    my $try = "$dir/$file";
  268.    return $try if (-f $try);
  269.   }
  270.  die "Cannot find $file in \@INC\n";
  271. }
  272.  
  273.  
  274. sub makefile
  275. {
  276.  my $self = shift;
  277.  my $str  = $self->MM::makefile;
  278.  my $mm = findINC('Tk/MMutil.pm');
  279.  my $cf = findINC('Tk/Config.pm');
  280.  $str =~ s/(\$\(CONFIGDEP\))/$1 $cf $mm/;
  281.  $str =~ s/\$\(OBJECT\)\s*:.*\n//;
  282.  return $str;
  283. }
  284.  
  285. sub installed_tk
  286. {
  287.  my $tk; 
  288.  my $dir;
  289.  foreach $dir (@INC)
  290.   {
  291.    if (-f "$dir/tkGlue.h")
  292.     {
  293.      $tk = $dir;
  294.      last;
  295.     }
  296.    my $try = "$dir/Tk";
  297.    if (-f "$try/tkGlue.h")
  298.     {
  299.      $tk = $try;
  300.      last;
  301.     }
  302.   }
  303.  die "Cannot find perl/Tk include files\n" unless (defined $tk);
  304.  $tk =~ s,^(\./)+,,;
  305.  return relpath($tk);
  306. }
  307.  
  308. sub installbin
  309. {
  310.  my ($self) = @_;
  311.  my $str  = $self->MM::installbin;
  312.  my $prog = 'perl'; # $self->{'MAP_TARGET'} || 'perl';
  313.  my $inc  = findINC("Tk/MMutil.pm");
  314.  $inc =~ s,/Tk/MMutil.pm$,,;
  315.  $inc = relpath($inc);
  316.  $str =~ s/^\tcp\s/\t\$(PERL) -I$inc -MTk::install -e installbin $prog /mg;
  317.  return $str;
  318. }
  319.  
  320. sub findpTk
  321. {
  322.  my $ptk;
  323.  my $dir;
  324.  foreach $dir (@INC)
  325.   {
  326.    my $try = "$dir/pTk";
  327.    if (-d $try && (-f "$try/Lang.h" || -f "$try/libpTk\$(LIB_EXT)"))
  328.     {
  329.      $ptk = $try;
  330.      last;
  331.     }
  332.   }
  333.  die "Cannot locate pTk\n" unless (defined $ptk); 
  334.  return relpath($ptk);
  335. }
  336.  
  337. sub TkExtMakefile
  338. {
  339.  my (%att) = @_;
  340.  unless (exists $att{'NAME'})
  341.   {
  342.    my $dir = getcwd;
  343.    my ($pack) = $dir =~ m#/([^/]+)$#;
  344.    if (defined $pack)
  345.     {
  346.      $att{NAME} = 'Tk::'.$pack;
  347.     }
  348.    else
  349.     {
  350.      warn "No Name and cannot deduce from '$dir'";
  351.     }
  352.   }
  353.  my $tk = installed_tk();
  354.  $att{'macro'} = {} unless (exists $att{'macro'});
  355.  $att{'macro'}{'TKDIR'} = $tk;
  356.  # 'INST_LIB' => '../blib',
  357.  # 'INST_ARCHLIB' => '../blib',
  358.  my @opt = ('VERSION'     => $Tk::Config::VERSION);
  359.  push(@opt,'clean' => {} ) unless (exists $att{'clean'});
  360.  $att{'clean'}->{FILES} = '' unless (exists $att{'clean'}->{FILES});
  361.  $att{'clean'}->{FILES} .= " *.bak";
  362.  unless (exists($att{'linkext'}) && $att{linkext}{LINKTYPE} eq '')
  363.   {
  364.    my @tm = (findINC('Tk/typemap'));
  365.    unshift(@tm,@{$att{'TYPEMAPS'}}) if (exists $att{'TYPEMAPS'});
  366.    $att{'TYPEMAPS'} = \@tm;
  367.    my $i = delete ($att{'INC'});
  368.    $i = (defined $i) ? "$i $inc" : $inc;
  369.    if (delete $att{'dynamic_ptk'})
  370.     {
  371.      my $ptk = findpTk();
  372.      push(@opt, 
  373.           'MYEXTLIB' => "$ptk/libpTk\$(LIB_EXT)",
  374.           'dynamic_lib' => {
  375.                              INST_DYNAMIC_DEP => "$ptk/libpTk\$(LIB_EXT)"
  376.                             }
  377.          ); 
  378.     }
  379.    if (delete $att{'ptk_include'})
  380.     {
  381.      my $ptk = findpTk();
  382.      $i = "-I$ptk $i" unless ($ptk eq '.');
  383.     }
  384.    else
  385.     {
  386.      $i = "-I$tk $i" unless ($tk eq '.');
  387.     }
  388.    push(@opt,'DEFINE' => $define, 'INC' => $i);
  389.   }
  390.  WriteMakefile(@opt, %att);
  391. }
  392.  
  393. sub import
  394. {
  395.  no strict 'refs';
  396.  my $class = shift;
  397.  my @list = (@_) ? @_ : @{"${class}::MYEXPORT"};
  398.  my $name;
  399.  foreach $name (@list)
  400.   {
  401.    *{"MY::$name"} = \&{"$name"};
  402.   }
  403. }
  404.  
  405.  
  406. 1;
  407.