home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume31 / mkskel / part01 / mkskel.pl < prev    next >
Perl Script  |  1992-08-26  |  10KB  |  311 lines
  1. #!/usr/local/bin/perl
  2. #            Copyright (c) 1992 by IRCAM
  3. #                All rights reserved.
  4. #
  5. #  For any information regarding this and other IRCAM software, please 
  6. #  send email to:
  7. #                              manager@ircam.fr
  8.  
  9. #
  10. # mkskel    2.8 IRCAM 8/24/92
  11. #
  12. # Create a skeleton file for a program in C, perl or sh.
  13. #
  14. # Modification history
  15. #
  16. # 28-Jul-92 - Michel Fingerhut (fingerhu@ircam.fr)
  17. #
  18.  
  19. #------------------------------------------------------------------------------
  20. # site-dependent configurable part (optional)
  21. #------------------------------------------------------------------------------
  22.  
  23. $ORG      = "IRCAM";            # no blanks
  24. $MAILHOST = "ircam.fr";            # fully qualified name (where author is)
  25. $MANAGER  = "manager@ircam.fr";        # full address whom to send questions to
  26. $IDSTRING = "%I\045 $ORG \045G%";    # for SCCS, e.g.. (\045=%...)
  27. $LOGSTRING= "Modification history";    # for RCS, might be $Log$, e.g.
  28. $LIBSKEL  = "/usr/local/lib/mkskel";    # where the skeletons are
  29. $NAME      = "NAME";            # default if not specified
  30. $MKDEPEND = "cc -Em";            # or "gcc -M"; if none, default code
  31.  
  32. #------------------------------------------------------------------------------
  33. # end of configuration
  34. #------------------------------------------------------------------------------
  35.  
  36. $[ = 1;                     # set array base to 1
  37. $, = ' ';                   # set output field separator
  38. $\ = "\n";                  # set output record separator
  39.  
  40. ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$dst) = localtime(time);
  41. %month= ( 1, 'Jan', 2, 'Feb', 3, 'Mar', 4, 'Apr', 5, 'May', 6, 'Jun',
  42.        7, 'Jul', 8, 'Aug', 9, 'Sep', 10, 'Oct', 11, 'Nov', 12, 'Dec');
  43. chop($hostname= `hostname`);
  44. $options = "s:l:t:rv";
  45. $usage   = "Usage: $0 [-v] [-r] [-l dir] [-t type] [-s source] [file]\n";
  46. require 'getopts.pl';
  47.  
  48. # check arguments and exit (before all the rest) if wrong
  49.  
  50. &Getopts($options) || die $usage  ;     # parse the arguments
  51.  
  52. if ($opt_v) {
  53.     print "2.8 IRCAM 8/24/92";
  54.     exit;
  55. }
  56.  
  57. if ($opt_r) {
  58.     ($IDSTRING, $LOGSTRING, $RCS) =('$Revision$ '."$ORG".' $Date$', '$Log$', 1);
  59. } else {
  60.     $SCCS= 1;
  61. }
  62.  
  63. #------------------------------------------------------------------------------
  64. # File types:         pattern:INTERPRETER:COB:COM:COE
  65. #------------------------------------------------------------------------------
  66. %types   = ("c",     ".+\.c::/*: *: */",
  67.             "cc",    ".+\.cc:://://://",
  68.         "csh",     ".+\.csh:/bin/csh:\043:\043:\043",
  69.         "h",     ".+\.h::/*: *: */",
  70.         "lisp",    ".+\.l::;:;:;",
  71.         "man",     ".+.\[1-8]::.\\\":.\\\":.\\\"",
  72.         "perl",     ".+\.pl|perl:/usr/local/bin/perl:#:#:#",
  73.         "sh",     ".+\.sh:/bin/sh:#:#:#",
  74.         "make",    "[Mm]akefile:/usr/local/bin/make:#:#:#",
  75.         "README",    "[Rr][Ee][Aa][Dd][Mm][Ee]::::"
  76.        );
  77.  
  78. #------------------------------------------------------------------------------
  79. # File types for Makefiles: pattern for name, name of variable
  80. #------------------------------------------------------------------------------
  81.  
  82. %subtypes= (".*\\.h",            "INCLUDES",
  83.         ".*\\.c",            "CFILES",
  84.         ".*\\.(cc|c\\+\\+)",    "CCFILES",
  85.         ".*\\.f",            "FFILES",
  86.         ".*\\.s",            "ASFILES",
  87.         ".*\\.y",            "YACCFILES",
  88.         ".*\\.a",            "LIBFILES",
  89.         ".*\\.l",            "LEXFILES",
  90.         ".*\\.(sh|csh|pl)",        "SHFILES",
  91.         ".*\\.1",            "MANFILES1",
  92.         ".*\\.2",            "MANFILES2",
  93.         ".*\\.3",            "MANFILES3",
  94.         ".*\\.4",            "MANFILES4",
  95.         ".*\\.5",            "MANFILES5",
  96.         ".*\\.6",            "MANFILES6",
  97.         ".*\\.7",            "MANFILES7",
  98.         ".*\\.8",            "MANFILES8",
  99.         ".*\\.(mm|me|doc|tex)",      "DOCFILES",
  100.         "README|INSTALL",          "DOCFILES",
  101.         );
  102.  
  103. %subtype  =("lib", 1, "sh", 1, "a.out", 1, "perl", 1, "csh", 1);
  104.  
  105. #-----------------------------------------------------------------------------
  106. # Check arguments
  107. #------------------------------------------------------------------------------
  108.  
  109. $LIBDIR= $opt_l || $LIBSKEL || "./lib";    # where the skeletons are
  110.  
  111. die "Unknown file type\n" if defined $opt_t && ! defined $types{$opt_t};
  112.  
  113. if ($#ARGV) {
  114.     $file= $ARGV[1];
  115.     ($suffix= $file) =~ s/.*\.//;
  116. }
  117.  
  118. #-----------------------------------------------------------------------------
  119. # Variables likely to be substituted
  120. #------------------------------------------------------------------------------
  121.  
  122. $MAILHOST = (gethostbyname($hostname))[1]     unless defined $MAILHOST;
  123. $MANAGER  = "root@$MAILHOST"             unless defined $MANAGER;
  124. $ORG      = "\U$1\E" if !defined $ORG && $MAILHOST =~ /\.([^\.]+)\.[^\.]*/;
  125. $IDSTRING = "%I\045 $ORG \045G%"         unless defined $IDSTRING;
  126. $LOGSTRING= $IDSTRING                unless defined $LOGSTRING;
  127. $DATE     = sprintf("%2d-%s-%d", $mday, $month{$mon+1}, $year);
  128. $LOGIN      = getlogin || (getpwuid($<))[1];
  129. $AUTHOR   = sprintf ("%s (%s@%s)", (getpwuid($<))[7], $LOGIN, $MAILHOST);
  130. $USER      = $ENV{'USER'};
  131. $HOME      = $ENV{'HOME'};
  132. $GROUP    = (getgrgid((getpwuid($<))[4]))[1];
  133. $YEAR      = "19$year";                # soon to modify...
  134. $FILENAME = $file                if defined $file; # else stdout
  135. $NAME     = (split(/\./, "\U$file\E"))[1]    if defined $file; # else default
  136. $Name     = "\U$1\E\L$2\E"             if $NAME=~ /(.)(.*)/;
  137. $name     = "\L$NAME\E";
  138. #-----------------------------------------------------------------------------
  139. # Determine type and execute
  140. #------------------------------------------------------------------------------
  141.  
  142. if (defined $opt_t) {
  143.     $type= $opt_t;
  144. } else {
  145.     foreach $t (keys %types) {
  146.     $pattern= (split(/:/, $types{$t}))[1];
  147.     $type= $t, last if defined $file && $file =~ /^$pattern$/;
  148.     }
  149. }
  150. die "Can't tell which type!\n" if ! defined $type;
  151. ($pattern, $INTERPRETER, $COB, $COM, $COE)= split(/:/, $types{$type});
  152. $SECTION= $suffix =~ /^[1-8]$/ ? $suffix : 1    if $type eq "man";
  153.  
  154. # special treatment for Makefiles
  155.  
  156. if ($type eq "make") {
  157.  
  158.     # Target name comes right next, no default
  159.  
  160.     $MAKEFILE= $ARGV[1] || "Makefile" ;
  161.     $TARGET  = $ARGV[2] || "a.out";
  162.  
  163.     # Type of processing (a.out, sh, lib, perl, csh)
  164.  
  165.     if (defined $opt_s) {
  166.     die "Unknown source type\n" if ! defined $subtype{$opt_s};
  167.     $subtype = $opt_s;
  168.     } elsif ($TARGET =~ /.a$/) {
  169.         $subtype = "lib";
  170.     } else {
  171.     $subtype = "a.out";
  172.     }
  173.     $subtype=~ s/\./_/g;
  174.     eval "\$\U$subtype\E= 1";
  175.  
  176.     # Define all variables according to the rest of the files
  177.  
  178.     foreach $file (@ARGV[3..$#ARGV]) {
  179.     foreach $s (keys %subtypes) {
  180.         eval "\$$subtypes{$s} .= \"$file \"", last if $file =~ /^$s$/;
  181.     }
  182.     }
  183. }
  184.  
  185. # now open the output and perform
  186.  
  187. &openfile($file)         if defined $file;
  188. &dofile("$LIBDIR/skel.$type");
  189.  
  190. #------------------------------------------------------------------------------
  191. # Open output file with backup
  192. #------------------------------------------------------------------------------
  193.  
  194. sub openfile {{
  195.     local($file)= $_[1];
  196.     if (-e $file) {
  197.     die "Files $file and $file.bak exist, not overwritten\n"
  198.         if -e "$file.bak";
  199.     print STDERR "renaming existing $file to $file.bak";
  200.     rename($file, "$file.bak");
  201.     }
  202.     open (STDOUT, ">$file") || die "Can't open $file for output: $!\n";
  203.     print STDERR "output file is $file";
  204. }}
  205.  
  206. #------------------------------------------------------------------------------
  207. # Read a file with substitutions and possible inclusions (recurse then)
  208. #------------------------------------------------------------------------------
  209.  
  210. sub dofile {{
  211.     local($file)= $_[1];
  212.     local($d)= 0;
  213.     open (FILE, $file) || die "Can't find $file: $!\n";
  214.  
  215.     push(cond, 1) if ! $#cond;            # initialize the stack
  216.     while (<FILE>) {
  217.     chop;
  218.  
  219.     # perform action if keyword and not nested in a skipped conditional
  220.  
  221.     $d++, $cond[$#cond]   && push(cond, $d, &docondition($1)),
  222.                     next    if /^@@IF (.*)$/;
  223.  
  224.     $d++, $cond[$#cond]   && push(cond, $d, ! &docondition($1)),
  225.                     next    if /^@@IFN (.*)$/;
  226.  
  227.     $d == $cond[$#cond-1] && push(cond, ! pop(cond)),
  228.                     next    if /^@@ELSE$/;
  229.  
  230.     $d == $cond[$#cond-1] && (pop(cond), pop(cond)), $d--,
  231.                     next    if /^@@FI$/;
  232.  
  233.                     next    if ! $cond[$#cond];
  234.  
  235.     &doinclude($1),         next    if /^@@INCLUDE (.*)$/;
  236.  
  237.     (print STDERR $1),        next    if /^@@MESSAGE (.*)$/;
  238.  
  239.     # if not keyword, substitute variable and print (conditionals first)
  240.  
  241.     while (/\$\${([^\?}]*)\?([^}]*)/) {    # find all conditionals
  242.         $cond= $1;
  243.         $value= $2;
  244.         &docondition($cond)? s/\$\${[^}]*}/$value/ : s/\$\${[^}]*}//;
  245.     }
  246.  
  247.     while (/.*\$\$(\w+).*/) {        # find all variables occurrences
  248.         $value= eval "\$$1";        # compute the value
  249.         s/\$\$$1/$value/;            # and do the replacement
  250.     }
  251.  
  252.     s/\\\$\\\$/\$\$/g;            # restore all escaped $$
  253.  
  254.         &printlongline($_);
  255.     }
  256.     close (FILE);
  257. }}
  258.  
  259. #------------------------------------------------------------------------------
  260. # doinclude - execute the INCLUDE directive
  261. #------------------------------------------------------------------------------
  262.  
  263. sub doinclude {{
  264.     local($file)= $_[1];
  265.  
  266.     $n++;                                                # for recursion
  267.     open("SAVE$n", "<&FILE") || die "dup: $!\n";    # save handle on "stack"
  268.     $where=tell(FILE);                                  # and place
  269.     &dofile("$LIBDIR/$file");                           # recurse on dofile
  270.     open(FILE, "<&SAVE$n") || die "dup: $!\n";      # restore handle
  271.     seek(FILE, $where, 0);                              # and place
  272. }}
  273.  
  274.  
  275. #------------------------------------------------------------------------------
  276. # docondition - evaluate a condition
  277. #------------------------------------------------------------------------------
  278.  
  279. sub docondition {{
  280.     local($condition)= "$".$_[1];
  281.  
  282.     $condition=~ s/\./_/g;
  283.     $condition=~ s/\|/\|\|\$/g;
  284.     $condition=~ s/\&/\&\&\$/g;
  285.  
  286.     "" ne eval $condition;
  287. }}
  288.  
  289. #------------------------------------------------------------------------------
  290. # printlongline - fold lines with continuation characters
  291. #------------------------------------------------------------------------------
  292.  
  293. sub printlongline {{
  294.     local($line)= $_[1];
  295.     local($max)= 80;    # for 1st line - 80, then less ('cause of tab)
  296.  
  297.     while (length($line) > $max) {
  298.  
  299.     # split at last white space before $max-2
  300.     ($l1, $l2)= ($1, $2)     if substr($line, 1, $max-2) =~/(.*)\s([^\s]*)/;
  301.  
  302.     # print segment and repeat
  303.     printf "$l1 \\\n\t";
  304.     $line= $l2.substr($line, $max-1);
  305.     $max= 72;
  306.     }
  307.  
  308.     # print last stuff
  309.     print $line;
  310. }}
  311.