gcc/ada/gnathtml.pl

   1 #! /usr/bin/env perl
   2
   3 #-----------------------------------------------------------------------------
   4 #-                                                                          --
   5 #-                         GNAT COMPILER COMPONENTS                         --
   6 #-                                                                          --
   7 #-                             G N A T H T M L                              --
   8 #-                                                                          --
   9 #-          Copyright (C) 1998-2008, Free Software Foundation, Inc.         --
  10 #-                                                                          --
  11 #- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 #- terms of the  GNU General Public License as published  by the Free Soft- --
  13 #- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 #- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 #- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 #- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 #- for  more details.  You should have  received  a copy of the GNU General --
  18 #- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 #- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 #- MA 02111-1307, USA.                                                      --
  21 #-                                                                          --
  22 #- GNAT was originally developed  by the GNAT team at  New York University. --
  23 #- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 #-                                                                          --
  25 #-----------------------------------------------------------------------------
  26
  27 ## This script converts an Ada file (and its dependency files) to Html.
  28 ## Keywords, comments and strings are color-hilighted. If the cross-referencing
  29 ## information provided by Gnat (when not using the -gnatx switch) is found,
  30 ## the html files will also have some cross-referencing features, i.e. if you
  31 ## click on a type, its declaration will be displayed.
  32 ##
  33 ## To find more about the switches provided by this script, please use the
  34 ## following command :
  35 ##     perl gnathtml.pl -h
  36 ## You may also change the first line of this script to indicates where Perl is
  37 ## installed on your machine, so that you can just type
  38 ##     gnathtml.pl -h
  39 ##
  40 ## Unless you supply another directory with the -odir switch, the html files
  41 ## will be saved saved in a html subdirectory
  42
  43 use Cwd 'abs_path';
  44 use File::Basename;
  45
  46 ### Print help if necessary
  47 sub print_usage
  48 {
  49   print "Usage is:\n";
  50   print "  $0 [switches] main_file[.adb] main_file2[.adb] ...\n";
  51   print "     -83       : Use Ada83 keywords only (default is Ada95)\n";
  52   print "     -cc color : Choose the color for comments\n";
  53   print "     -d        : Convert also the files which main_file depends on\n";
  54   print "     -D        : same as -d, also looks for files in the standard library\n";
  55   print "     -f        : Include cross-references for local entities too\n";
  56   print "     -absolute : Display absolute filenames in the headers\n";
  57   print "     -h        : Print this help page\n";
  58   print "     -lnb      : Display line numbers every nb lines\n";
  59   print "     -Idir     : Specify library/object files search path\n";
  60   print "     -odir     : Name of the directory where the html files will be\n";
  61   print "                 saved. Default is 'html/'\n";
  62   print "     -pfile    : Use file as a project file (.adp file)\n";
  63   print "     -sc color : Choose the color for symbol definitions\n";
  64   print "     -Tfile    : Read the name of the files from file rather than the\n";
  65   print "                 command line\n";
  66   print "     -ext ext  : Choose the generated file names extension (default\n";
  67   print "                 is htm)\n";
  68   print "This program attemps to generate an html file from an Ada file\n";
  69   exit;
  70 }
  71
  72 ### Parse the command line
  73 local ($ada83_mode)    = 0;
  74 local ($prjfile)       = "";
  75 local (@list_files)    = ();
  76 local ($line_numbers)  = 0;
  77 local ($dependencies)  = 0;
  78 local ($standard_library) = 0;
  79 local ($output_dir)    = "html";
  80 local ($xref_variable) = 0;
  81 local (@search_dir)    = ('.');
  82 local ($tab_size)      = 8;
  83 local ($comment_color) = "green";
  84 local ($symbol_color)  = "red";
  85 local ($absolute)      = 0;
  86 local ($fileext)       = "htm";
  87
  88 while ($_ = shift @ARGV)
  89 {
  90   /^-83$/  &&   do { $ada83_mode = 1; };
  91   /^-d$/   &&   do { $dependencies = 1; };
  92   /^-D$/   &&   do { $dependencies = 1;
  93                      $standard_library = 1; };
  94   /^-f$/   &&   do { $xref_variable = 1; };
  95   /^-absolute$/ && do {$absolute = 1; };
  96   /^-h$/   &&   do { &print_usage; };
  97   /^[^-]/  &&   do { $_ .= ".adb" if (! /\.ad[bs]$/);
  98                      push (@list_files, $_); };
  99
 100   if (/^-o\s*(.*)$/)
 101   {
 102     $output_dir = ($1 eq "") ? shift @ARGV : $1;
 103     chop $output_dir if ($output_dir =~ /\/$/);
 104     &print_usage if ($output_dir =~ /^-/ || $output_dir eq "");
 105   }
 106
 107   if (/^-T\s*(.*)$/)
 108   {
 109       my ($source_file) = ($1 eq "") ? shift @ARGV : $1;
 110       local (*SOURCE);
 111       open (SOURCE, "$source_file") || die "file not found: $source_file";
 112       while (<SOURCE>) {
 113           @files = split;
 114           foreach (@files) {
 115               $_ .= ".adb" if (! /\.ad[bs]$/);
 116               push (@list_files, $_);
 117           }
 118       }
 119   }
 120
 121   if (/^-cc\s*(.*)$/)
 122   {
 123       $comment_color = ($1 eq "") ? shift @ARGV : $1;
 124       &print_usage if ($comment_color =~ /^-/ || $comment_color eq "");
 125   }
 126
 127   if (/^-sc\s*(.*)$/)
 128   {
 129       $symbol_color = ($1 eq "") ? shift @ARGV : $1;
 130       &print_usage if ($symbol_color =~ /^-/ || $symbol_color eq "");
 131   }
 132
 133   if (/^-I\s*(.*)$/)
 134   {
 135     push (@search_dir, ($1 eq "") ? scalar (shift @ARGV) : $1);
 136   }
 137
 138   if (/^-p\s*(.*)$/)
 139   {
 140     $prjfile = ($1 eq "") ? shift @ARGV : $1;
 141     &print_usage if ($prjfile =~ /^-/ || $prjfile eq "");
 142   }
 143
 144   if (/^-l\s*(.*)$/)
 145   {
 146     $line_numbers = ($1 eq "") ? shift @ARGV : $1;
 147     &print_usage if ($line_numbers =~ /^-/ || $line_numbers eq "");
 148   }
 149
 150   if (/^-ext\s*(.*)$/)
 151   {
 152     $fileext = ($1 eq "") ? shift @ARGV : $1;
 153     &print_usage if ($fileext =~ /^-/ || $fileext eq "");
 154   }
 155 }
 156
 157 &print_usage if ($#list_files == -1);
 158 local (@original_list) = @list_files;
 159
 160 ## This regexp should match all the files from the standard library (and only them)
 161 ## Note that at this stage the '.' in the file names has been replaced with __
 162 $standard_file_regexp="^([agis]-|ada__|gnat__|system__|interface__).*\$";
 163
 164 local (@src_dir) = ();
 165 local (@obj_dir) = ();
 166
 167 if ($standard_library) {
 168     open (PIPE, "gnatls -v | ");
 169     local ($mode) = "";
 170     while (defined ($_ = <PIPE>)) {
 171         chop;
 172         s/^\s+//;
 173         $_ = './' if (/<Current_Directory>/);
 174         next if (/^$/);
 175
 176         if (/Source Search Path:/) {
 177             $mode = 's';
 178         }
 179         elsif (/Object Search Path:/) {
 180             $mode = 'o';
 181         }
 182         elsif ($mode eq 's') {
 183             push (@src_dir, $_);
 184         }
 185         elsif ($mode eq 'o') {
 186             push (@obj_dir, $_);
 187         }
 188     }
 189     close (PIPE);
 190 }
 191 else
 192 {
 193     push (@src_dir, "./");
 194     push (@obj_dir, "./");
 195 }
 196
 197 foreach (@list_files) {
 198   local ($dir) = $_;
 199   $dir =~ s/\/([^\/]+)$//;
 200   push (@src_dir, $dir. '/');
 201   push (@obj_dir, $dir. '/');
 202 }
 203
 204 ### Defines and compiles the Ada key words :
 205 local (@Ada_keywords) = ('abort', 'abs', 'accept', 'access', 'all', 'and',
 206                          'array', 'at', 'begin', 'body', 'case', 'constant',
 207                          'declare', 'delay', 'delta', 'digits', 'do', 'else',
 208                          'elsif', 'end', 'entry', 'exception', 'exit', 'for',
 209                          'function', 'generic', 'goto', 'if', 'in', 'is',
 210                          'limited', 'loop', 'mod', 'new', 'not', 'null', 'of',
 211                          'or', 'others', 'out', 'package', 'pragma', 'private',
 212                          'procedure', 'raise', 'range', 'record', 'rem',
 213                          'renames', 'return', 'reverse', 'select', 'separate',
 214                          'subtype', 'task', 'terminate', 'then', 'type',
 215                          'until', 'use', 'when', 'while', 'with', 'xor');
 216 local (@Ada95_keywords) = ('abstract', 'aliased', 'protected', 'requeue',
 217                         'tagged');
 218
 219 local (%keywords) = ();
 220 grep (++ $keywords{$_}, @Ada_keywords);
 221 grep (++ $keywords{$_}, @Ada95_keywords) unless ($ada83_mode);
 222
 223 ### Symbols declarations for the current file
 224 ### format is   (line_column => 1, ...)
 225 local (%symbols);
 226
 227 ### Symbols usage for the current file
 228 ### format is  ($adafile#$line_$column => $htmlfile#$linedecl_$columndecl, ...)
 229 local (%symbols_used);
 230
 231 ### the global index of all symbols
 232 ### format is  ($name => [[file, line, column], [file, line, column], ...])
 233 local (%global_index);
 234
 235 #########
 236 ##  This function create the header of every html file.
 237 ##  These header is returned as a string
 238 ##  Params:  - Name of the Ada file associated with this html file
 239 #########
 240 sub create_header
 241 {
 242   local ($adafile) = shift;
 243   local ($string) = "<HEAD><TITLE>$adafile</TITLE></HEAD>
 244 <BODY>\n";
 245
 246   if ($adafile ne "")
 247   {
 248     $string .= "<HR><DIV ALIGN=\"center\"><H1> File : $adafile "
 249         . "</H1></DIV><HR>\n<PRE>";
 250   }
 251   return $string;
 252 }
 253
 254 #########
 255 ##  Protect a string (or character) from the Html parser
 256 ##  Params: - the string to protect
 257 ##  Out:    - the protected string
 258 #########
 259 sub protect_string
 260 {
 261     local ($string) = shift;
 262     $string =~ s/&/&amp;/g;
 263     $string =~ s/</&lt;/g;
 264     $string =~ s/>/&gt;/g;
 265     return $string;
 266 }
 267
 268 #########
 269 ##  This function creates the footer of the html file
 270 ##  The footer is returned as a string
 271 ##  Params :  - Name of the Ada file associated with this html file
 272 #########
 273 sub create_footer
 274 {
 275   local ($adafile) = shift;
 276   local ($string) = "";
 277   $string = "</PRE>" if ($adafile ne "");
 278   return $string . "</BODY></HTML>\n";
 279 }
 280
 281 #########
 282 ##  This function creates the string to use for comment output
 283 ##  Params :  - the comment itself
 284 #########
 285 sub output_comment
 286 {
 287   local ($comment) = &protect_string (shift);
 288   return "<FONT COLOR=$comment_color><EM>--$comment</EM></FONT>";
 289 }
 290
 291 ########
 292 ##  This function creates the string to use for symbols output
 293 ##  Params :  - the symbol to output
 294 ##            - the current line
 295 ##            - the current column
 296 ########
 297 sub output_symbol
 298 {
 299   local ($symbol) = &protect_string (shift);
 300   local ($lineno) = shift;
 301   local ($column) = shift;
 302   return "<FONT COLOR=$symbol_color><A NAME=\"$lineno\_$column\">$symbol</A></FONT>";
 303 }
 304
 305 ########
 306 ##  This function creates the string to use for keyword output
 307 ##  Params :  - the keyword to output
 308 ########
 309 sub output_keyword
 310 {
 311   local ($keyw) = shift;
 312   return "<b>$keyw</b>";
 313 }
 314
 315 ########
 316 ##  This function outputs a line number
 317 ##  Params :  - the line number to generate
 318 ########
 319 sub output_line_number
 320 {
 321   local ($no) = shift;
 322   if ($no != -1)
 323   {
 324     return "<EM><FONT SIZE=-1>" . sprintf ("%4d ", $no) . "</FONT></EM>";
 325   }
 326   else
 327   {
 328     return "<FONT SIZE=-1>     </FONT>";
 329   }
 330 }
 331
 332 ########
 333 ##  Converts a character into the corresponding Ada type
 334 ##  This is based on the ali format (see lib-xref.adb) in the GNAT sources
 335 ##  Note: 'f' or 'K' should be returned in case a link from the body to the
 336 ##        spec needs to be generated.
 337 ##  Params : - the character to convert
 338 ########
 339 sub to_type
 340 {
 341   local ($char) = shift;
 342   $char =~ tr/a-z/A-Z/;
 343
 344   return 'array'                              if ($char eq 'A');
 345   return 'boolean'                            if ($char eq 'B');
 346   return 'class'                              if ($char eq 'C');
 347   return 'decimal'                            if ($char eq 'D');
 348   return 'enumeration'                        if ($char eq 'E');
 349   return 'floating point'                     if ($char eq 'F');
 350   return 'signed integer'                     if ($char eq 'I');
 351   # return 'generic package'                    if ($char eq 'K');
 352   return 'block'                              if ($char eq 'L');
 353   return 'modular integer'                    if ($char eq 'M');
 354   return 'enumeration litteral'               if ($char eq 'N');
 355   return 'ordinary fixed point'               if ($char eq 'O');
 356   return 'access'                             if ($char eq 'P');
 357   return 'label'                              if ($char eq 'Q');
 358   return 'record'                             if ($char eq 'R');
 359   return 'string'                             if ($char eq 'S');
 360   return 'task'                               if ($char eq 'T');
 361   return 'f'                                  if ($char eq 'U');
 362   return 'f'                                  if ($char eq 'V');
 363   return 'exception'                          if ($char eq 'X');
 364   return 'entry'                              if ($char eq 'Y');
 365   return "$char";
 366 }
 367
 368 ########
 369 ##  Changes a file name to be http compatible
 370 ########
 371 sub http_string
 372 {
 373   local ($str) = shift;
 374   $str =~ s/\//__/g;
 375   $str =~ s/\\/__/g;
 376   $str =~ s/:/__/g;
 377   $str =~ s/\./__/g;
 378   return $str;
 379 }
 380
 381 ########
 382 ##  Creates the complete file-name, with directory
 383 ##  use the variables read in the .prj file
 384 ##  Params : - file name
 385 ##  RETURNS : the relative path_name to the file
 386 ########
 387 sub get_real_file_name
 388 {
 389   local ($filename) = shift;
 390   local ($path) = $filename;
 391
 392   foreach (@src_dir)
 393   {
 394       if ( -r "$_$filename")
 395       {
 396           $path = "$_$filename";
 397           last;
 398       }
 399   }
 400
 401   $path =~ s/^\.\///;
 402   return $path if (substr ($path, 0, 1) ne '/');
 403
 404   ## We want to return relative paths only, so that the name of the HTML files
 405   ## can easily be generated
 406   local ($pwd) = `pwd`;
 407   chop ($pwd);
 408   local (@pwd) = split (/\//, $pwd);
 409   local (@path) = split (/\//, $path);
 410
 411   while (@pwd)
 412   {
 413     if ($pwd [0] ne $path [0])
 414     {
 415       return '../' x ($#pwd + 1) . join ("/", @path);
 416     }
 417     shift @pwd;
 418     shift @path;
 419   }
 420   return join ('/', @path);
 421 }
 422
 423 ########
 424 ##  Reads and parses .adp files
 425 ##  Params : - adp file name
 426 ########
 427 sub parse_prj_file
 428 {
 429   local ($filename) = shift;
 430   local (@src) = ();
 431   local (@obj) = ();
 432
 433   print "Parsing project file : $filename\n";
 434
 435   open (PRJ, $filename) || do { print " ... sorry, file not found\n";
 436                                 return;
 437                               };
 438   while (<PRJ>)
 439   {
 440     chop;
 441     s/\/$//;
 442     push (@src, $1 . "/") if (/^src_dir=(.*)/);
 443     push (@obj, $1 . "/") if (/^obj_dir=(.*)/);
 444   }
 445   unshift (@src_dir, @src);
 446   unshift (@obj_dir, @obj);
 447   close (PRJ);
 448 }
 449
 450 ########
 451 ##  Finds a file in the search path
 452 ##  Params  : - the name of the file
 453 ##  RETURNS : - the directory/file_name
 454 ########
 455 sub find_file
 456 {
 457   local ($filename) = shift;
 458
 459   foreach (@search_dir) {
 460     if (-f "$_/$filename") {
 461       return "$_/$filename";
 462     }
 463   }
 464   return $filename;
 465 }
 466
 467 ########
 468 ##  Inserts a new reference in the list of references
 469 ##  Params: - Ref as it appears in the .ali file ($line$type$column)
 470 ##          - Current file for the reference
 471 ##          - Current offset to be added from the line (handling of
 472 ##            pragma Source_Reference)
 473 ##          - Current entity reference
 474 ##  Modifies: - %symbols_used
 475 ########
 476 sub create_new_reference
 477 {
 478     local ($ref) = shift;
 479     local ($lastfile) = shift;
 480     local ($offset) = shift;
 481     local ($currentref) = shift;
 482     local ($refline, $type, $refcol);
 483
 484     ## Do not generate references to the standard library files if we
 485     ## do not generate the corresponding html files
 486     return if (! $standard_library && $lastfile =~ /$standard_file_regexp/);
 487
 488     ($refline, $type, $extern, $refcol) = /(\d+)(.)(<[^>]+>)?(\d+)/;
 489     $refline += $offset;
 490
 491     ## If we have a body, then we only generate the cross-reference from
 492     ## the spec to the body if we have a subprogram (or a package)
 493
 494
 495     if ($type eq "b")
 496 #       && ($symbols {$currentref} eq 'f' || $symbols {$currentref} eq 'K'))
 497     {
 498         local ($cref_file, $cref) = ($currentref =~ /([^\#]+).$fileext\#(.+)/);
 499
 500         $symbols_used {"$cref_file#$cref"} = "$lastfile.$fileext#$refline\_$refcol";
 501         $symbols_used {"$lastfile#$refline\_$refcol"} = $currentref;
 502         $symbols {"$lastfile.$fileext#$refline\_$refcol"} = "body";
 503     }
 504
 505     ## Do not generate cross-references for "e" and "t", since these point to the
 506     ## semicolon that terminates the block -- irrelevant for gnathtml
 507     ## "p" is also removed, since it is used for primitive subprograms
 508     ## "d" is also removed, since it is used for discriminants
 509     ## "i" is removed since it is used for implicit references
 510     ## "z" is used for generic formals
 511     ## "k" is for references to parent package
 512     ## "=", "<", ">", "^" is for subprogram parameters
 513
 514     elsif ($type !~ /[eztpid=<>^k]/)
 515     {
 516         $symbols_used {"$lastfile#$refline\_$refcol"} = $currentref;
 517     }
 518 }
 519
 520 ########
 521 ##  Parses the ali file associated with the current Ada file
 522 ##  Params :  - the complete ali file name
 523 ########
 524 sub parse_ali
 525 {
 526   local ($filename) = shift;
 527   local ($currentfile);
 528   local ($currentref);
 529   local ($lastfile);
 530
 531   # A    file | line type column      reference
 532   local ($reference) = "(?:(?:\\d+\\|)?\\d+.\\d+|\\w+)";
 533
 534   # The following variable is used to represent the possible xref information
 535   # output by GNAT when -gnatdM is used. It includes renaming references, and
 536   # references to the parent type, as well as references to the generic parent
 537
 538   local ($typeref) = "(?:=$reference|<$reference>|\\{$reference\\}|\\($reference\\)|\\[$reference\\])?";
 539
 540   # The beginning of an entity declaration line in the ALI file
 541   local ($decl_line) = "^(\\d+)(.)(\\d+)[ *]([\\w\\d.-]+|\"..?\")$typeref\\s+(\\S.*)?\$";
 542
 543   # Contains entries of the form  [ filename source_reference_offset]
 544   # Offset needs to be added to the lines read in the cross-references, and are
 545   # used when the source comes from a gnatchop-ed file. See lib-write.ads, lines
 546   # with ^D in the ALI file.
 547   local (@reffiles) = ();
 548
 549   open (ALI, &find_file ($filename)) || do {
 550     print "no ", &find_file ($filename), " file...\n";
 551     return;
 552   };
 553   local (@ali) = <ALI>;
 554   close (ALI);
 555
 556   undef %symbols;
 557   undef %symbols_used;
 558
 559   foreach (@ali)
 560   {
 561     ## The format of D lines is
 562     ## D source-name time-stamp checksum [subunit-name] line:file-name
 563
 564     if (/^D\s+([\w\d.-]+)\s+\S+ \S+(\s+\D[^: ]+)?( (\d+):(.*))?/)
 565     {
 566         # The offset will be added to each cross-reference line. If it is
 567         # greater than 1, this means that we have a pragma Source_Reference,
 568         # and this must not be counted in the xref information.
 569         my ($file, $offset) = ($1, (defined $4) ? 2 - $4 : 0);
 570
 571         if ($dependencies)
 572         {
 573             push (@list_files, $1) unless (grep (/$file/, @list_files));
 574         }
 575         push (@reffiles, [&http_string (&get_real_file_name ($file)), $offset]);
 576     }
 577
 578     elsif (/^X\s+(\d+)/)
 579     {
 580         $currentfile = $lastfile = $1 - 1;
 581     }
 582
 583     elsif (defined $currentfile && /$decl_line/)
 584     {
 585       my ($line) = $1 + $reffiles[$currentfile][1];
 586       next if (! $standard_library
 587                && $reffiles[$currentfile][0] =~ /$standard_file_regexp/);
 588       if ($xref_variable || $2 eq &uppercases ($2))
 589       {
 590         $currentref = $reffiles[$currentfile][0] . ".$fileext#$line\_$3";
 591         $symbols {$currentref} = &to_type ($2);
 592         $lastfile = $currentfile;
 593
 594         local ($endofline) = $5;
 595
 596         foreach (split (" ", $endofline))
 597         {
 598             (s/^(\d+)\|//) && do { $lastfile = $1 - 1; };
 599             &create_new_reference
 600                 ($_, $reffiles[$lastfile][0],
 601                  $reffiles[$lastfile][1], $currentref);
 602         }
 603       }
 604       else
 605       {
 606         $currentref = "";
 607       }
 608     }
 609     elsif (/^\.\s(.*)/ && $reffiles[$currentfile][0] ne "" && $currentref ne "")
 610     {
 611       next if (! $standard_library
 612                && $reffiles[$currentfile][0] =~ /$standard_file_regexp/);
 613       foreach (split (" ", $1))
 614       {
 615           (s/^(\d+)\|//) && do { $lastfile = $1 - 1; };
 616           &create_new_reference
 617               ($_, $reffiles[$lastfile][0], $reffiles[$lastfile][1],
 618                $currentref);
 619       }
 620     }
 621   }
 622 }
 623
 624 #########
 625 ##  Return the name of the ALI file to use for a given source
 626 ##  Params:  - Name of the source file
 627 ##  return:  Name and location of the ALI file
 628 #########
 629
 630 sub ali_file_name {
 631     local ($source) = shift;
 632     local ($alifilename, $unitname);
 633     local ($in_separate) = 0;
 634
 635     $source =~ s/\.ad[sb]$//;
 636     $alifilename = $source;
 637     $unitname = $alifilename;
 638     $unitname =~ s/-/./g;
 639
 640     ## There are two reasons why we might not find the ALI file: either the
 641     ## user did not generate them at all, or we are working on a separate unit.
 642     ## Thus, we search in the parent's ALI file.
 643
 644     while ($alifilename ne "") {
 645
 646       ## Search in the object path
 647       foreach (@obj_dir) {
 648
 649         ## Check if the ALI file does apply to the source file
 650         ## We check the ^D lines, which have the following format:
 651         ## D source-name time-stamp checksum [subunit-name] line:file-name
 652
 653         if (-r "$_$alifilename.ali") {
 654           if ($in_separate) {
 655             open (FILE, "$_$alifilename.ali");
 656
 657             if (grep (/^D \S+\s+\S+\s+\S+ $unitname/, <FILE>)) {
 658               close FILE;
 659               return "$_$alifilename.ali";
 660
 661             } else {
 662               ## If the ALI file doesn't apply to the source file, we can
 663               ## return now, since there won't be a parent ALI file above
 664               ## anyway
 665               close FILE;
 666               return "$source.ali";
 667             }
 668           } else {
 669             return "$_$alifilename.ali";
 670           }
 671         }
 672       }
 673
 674       ## Get the parent's ALI file name
 675
 676       if (! ($alifilename =~ s/-[^-]+$//)) {
 677         $alifilename = "";
 678       }
 679       $in_separate = 1;
 680     }
 681
 682     return "$source.ali";
 683 }
 684
 685 #########
 686 ## Convert a path to an absolute path
 687 #########
 688
 689 sub to_absolute
 690 {
 691   local ($path) = shift;
 692   local ($name, $suffix, $separator);
 693   ($name,$path,$suffix) = fileparse ($path, ());
 694   $path = &abs_path ($path);
 695   $separator = substr ($path, 0, 1);
 696   return $path . $separator . $name;
 697 }
 698
 699 #########
 700 ##  This function outputs the html version of the file FILE
 701 ##  The output is send to FILE.htm.
 702 ##  Params :  - Name of the file to convert (ends with .ads or .adb)
 703 #########
 704 sub output_file
 705 {
 706   local ($filename_param) = shift;
 707   local ($lineno)   = 1;
 708   local ($column);
 709   local ($found);
 710
 711   local ($alifilename) = &ali_file_name ($filename_param);
 712
 713   $filename = &get_real_file_name ($filename_param);
 714   $found = &find_file ($filename);
 715
 716   ## Read the whole file
 717   open (FILE, $found) || do {
 718     print $found, " not found ... skipping.\n";
 719     return 0;
 720   };
 721   local (@file) = <FILE>;
 722   close (FILE);
 723
 724   ## Parse the .ali file to find the cross-references
 725   print "converting ", $filename, "\n";
 726   &parse_ali ($alifilename);
 727
 728   ## Create and initialize the html file
 729   open (OUTPUT, ">$output_dir/" . &http_string ($filename) . ".$fileext")
 730       || die "Couldn't write $output_dir/" . &http_string ($filename)
 731           . ".$fileext\n";
 732
 733   if ($absolute) {
 734      print OUTPUT &create_header (&to_absolute ($found)), "\n";
 735   } else {
 736      print OUTPUT &create_header ($filename_param), "\n";
 737   }
 738
 739   ## Print the file
 740   $filename = &http_string ($filename);
 741   foreach (@file)
 742   {
 743       local ($index);
 744       local ($line) = $_;
 745       local ($comment);
 746
 747       $column = 1;
 748       chop ($line);
 749
 750       ## Print either the line number or a space if required
 751       if ($line_numbers)
 752       {
 753           if ($lineno % $line_numbers == 0)
 754           {
 755               print OUTPUT &output_line_number ($lineno);
 756           }
 757           else
 758           {
 759               print OUTPUT &output_line_number (-1);
 760           }
 761       }
 762
 763       ## First, isolate any comment on the line
 764       undef $comment;
 765       $index = index ($line, '--');
 766       if ($index != -1) {
 767           $comment = substr ($line, $index + 2);
 768           if ($index > 1)
 769           {
 770               $line = substr ($line, 0, $index);
 771           }
 772           else
 773           {
 774               undef $line;
 775           }
 776       }
 777
 778       ## Then print the line
 779       if (defined $line)
 780       {
 781           $index = 0;
 782           while ($index < length ($line))
 783           {
 784               local ($substring) = substr ($line, $index);
 785
 786               if ($substring =~ /^\t/)
 787               {
 788                   print OUTPUT ' ' x ($tab_size - (($column - 1) % $tab_size));
 789                   $column += $tab_size - (($column - 1) % $tab_size);
 790                   $index ++;
 791               }
 792               elsif ($substring =~ /^(\w+)/
 793                      || $substring =~ /^("[^\"]*")/
 794                      || $substring =~ /^(\W)/)
 795               {
 796                   local ($word) = $1;
 797                   $index += length ($word);
 798
 799                   local ($lowercase) = $word;
 800                   $lowercase =~ tr/A-Z/a-z/;
 801
 802                   if ($keywords{$lowercase})
 803                   {
 804                       print OUTPUT &output_keyword ($word);
 805                   }
 806                   elsif ($symbols {"$filename.$fileext#$lineno\_$column"})
 807                   {
 808                       ##  A symbol can both have a link and be a reference for
 809                       ##  another link, as is the case for bodies and
 810                       ##  declarations
 811
 812                       if ($symbols_used{"$filename#$lineno\_$column"})
 813                       {
 814                           print OUTPUT "<A HREF=\"",
 815                           $symbols_used{"$filename#$lineno\_$column"},
 816                           "\">", &protect_string ($word), "</A>";
 817                           print OUTPUT &output_symbol ('', $lineno, $column);
 818                       }
 819                       else
 820                       {
 821                           print OUTPUT &output_symbol ($word, $lineno, $column);
 822                       }
 823
 824                       ## insert only functions into the global index
 825
 826                       if ($symbols {"$filename.$fileext#$lineno\_$column"} eq 'f')
 827                       {
 828                           push (@{$global_index {$word}},
 829                                 [$filename_param, $filename, $lineno, $column]);
 830                       }
 831                   }
 832                   elsif ($symbols_used{"$filename#$lineno\_$column"})
 833                   {
 834                       print OUTPUT "<A HREF=\"",
 835                       $symbols_used{"$filename#$lineno\_$column"},
 836                       "\">", &protect_string ($word), "</A>";
 837                   }
 838                   else
 839                   {
 840                       print OUTPUT &protect_string ($word);
 841                   }
 842                   $column += length ($word);
 843               }
 844               else
 845               {
 846                   $index ++;
 847                   $column ++;
 848                   print OUTPUT &protect_string (substr ($substring, 0, 1));
 849               }
 850           }
 851       }
 852
 853       ## Then output the comment
 854       print OUTPUT &output_comment ($comment) if (defined $comment);
 855       print OUTPUT "\n";
 856
 857       $lineno ++;
 858   }
 859
 860   print OUTPUT &create_footer ($filename);
 861   close (OUTPUT);
 862   return 1;
 863 }
 864
 865 #########
 866 ##  This function generates the global index
 867 #########
 868 sub create_index_file
 869 {
 870   open (INDEX, ">$output_dir/index.$fileext") || die "couldn't write $output_dir/index.$fileext";
 871
 872   print INDEX <<"EOF";
 873 <HTML>
 874 <HEAD><TITLE>Source Browser</TITLE></HEAD>
 875 <FRAMESET COLS='250,*'>
 876 <NOFRAME>
 877 EOF
 878   ;
 879
 880   local (@files) = &create_file_index;
 881   print INDEX join ("\n", @files), "\n";
 882
 883   print INDEX "<HR>\n";
 884   local (@functions) = &create_function_index;
 885   print INDEX join ("\n", @functions), "\n";
 886
 887   print INDEX <<"EOF";
 888 </NOFRAME>
 889 <FRAMESET ROWS='50%,50%'>
 890 <FRAME NAME=files SRC=files.$fileext>
 891 <FRAME NAME=funcs SRC=funcs.$fileext>
 892 </FRAMESET>
 893 <FRAME NAME=main SRC=main.$fileext>
 894 </FRAMESET>
 895 </HTML>
 896 EOF
 897   ;
 898   close (INDEX);
 899
 900   open (MAIN, ">$output_dir/main.$fileext") || die "couldn't write $output_dir/main.$fileext";
 901   print MAIN &create_header (""),
 902   "<P ALIGN=right>",
 903   "<A HREF=main.$fileext TARGET=_top>[No frame version is here]</A>",
 904   "<P>",
 905   join ("\n", @files), "\n<HR>",
 906   join ("\n", @functions), "\n";
 907
 908   if ($dependencies) {
 909       print MAIN "<HR>\n";
 910       print MAIN "You should start your browsing with one of these files:\n";
 911       print MAIN "<UL>\n";
 912       foreach (@original_list) {
 913           print MAIN "<LI><A HREF=", &http_string (&get_real_file_name ($_)),
 914              ".$fileext>$_</A>\n";
 915       }
 916   }
 917   print MAIN &create_footer ("");
 918   close (MAIN);
 919 }
 920
 921 #######
 922 ##  Convert to upper cases (did not exist in Perl 4)
 923 #######
 924
 925 sub uppercases {
 926   local ($tmp) = shift;
 927   $tmp =~ tr/a-z/A-Z/;
 928   return $tmp;
 929 }
 930
 931 #######
 932 ##  This function generates the file_index
 933 ##  RETURN : - table with the html lines to be printed
 934 #######
 935 sub create_file_index
 936 {
 937   local (@output) = ("<H2 ALIGN=CENTER>Files</H2>");
 938
 939
 940   open (FILES, ">$output_dir/files.$fileext") || die "couldn't write $output_dir/files.$fileext";
 941   print FILES &create_header (""), join ("\n", @output), "\n";
 942
 943
 944   if ($#list_files > 20)
 945   {
 946     local ($last_letter) = '';
 947     foreach (sort {&uppercases ($a) cmp &uppercases ($b)} @list_files)
 948     {
 949       next if ($_ eq "");
 950       if (&uppercases (substr ($_, 0, 1)) ne $last_letter)
 951       {
 952         if ($last_letter ne '')
 953         {
 954           print INDEX_FILE "</UL></BODY></HTML>\n";
 955           close (INDEX_FILE);
 956         }
 957         $last_letter = &uppercases (substr ($_, 0, 1));
 958         open (INDEX_FILE, ">$output_dir/files/$last_letter.$fileext")
 959         || die "couldn't write $output_dir/files/$last_letter.$fileext";
 960         print INDEX_FILE <<"EOF";
 961 <HTML><HEAD><TITLE>$last_letter</TITLE></HEAD>
 962 <BODY>
 963 <H2>Files - $last_letter</H2>
 964 <A HREF=../files.$fileext TARGET=_self>[index]</A>
 965 <UL COMPACT TYPE=DISC>
 966 EOF
 967         ;
 968         local ($str) = "<A HREF=files/$last_letter.$fileext>[$last_letter]</A>";
 969         push (@output, $str);
 970         print FILES "$str\n";
 971       }
 972       print INDEX_FILE "<LI><A HREF=../",
 973       &http_string (&get_real_file_name ($_)),
 974       ".$fileext TARGET=main>$_</A>\n";   ## Problem with TARGET when in no_frame mode!
 975     }
 976
 977     print INDEX_FILE "</UL></BODY></HTML>\n";
 978     close INDEX_FILE;
 979   }
 980   else
 981   {
 982     push (@output, "<UL COMPACT TYPE=DISC>");
 983     print FILES "<UL COMPACT TYPE=DISC>";
 984     foreach (sort {&uppercases ($a) cmp &uppercases ($b)} @list_files)
 985     {
 986       next if ($_ eq "");
 987       local ($ref) = &http_string (&get_real_file_name ($_));
 988       push (@output, "<LI><A HREF=$ref.$fileext>$_</A>");
 989       print FILES "<LI><A HREF=$ref.$fileext TARGET=main>$_</A>\n";
 990     }
 991   }
 992
 993   print FILES &create_footer ("");
 994   close (FILES);
 995
 996   push (@output, "</UL>");
 997   return @output;
 998 }
 999
1000 #######
1001 ##  This function generates the function_index
1002 ##  RETURN : - table with the html lines to be printed
1003 #######
1004 sub create_function_index
1005 {
1006   local (@output) = ("<H2 ALIGN=CENTER>Functions/Procedures</H2>");
1007   local ($initial) = "";
1008
1009   open (FUNCS, ">$output_dir/funcs.$fileext") || die "couldn't write $output_dir/funcs.$fileext";
1010   print FUNCS &create_header (""), join ("\n", @output), "\n";
1011
1012   ## If there are more than 20 entries, we just want to create some
1013   ## submenus
1014   if (scalar (keys %global_index) > 20)
1015   {
1016     local ($last_letter) = '';
1017     foreach (sort {&uppercases ($a) cmp &uppercases ($b)} keys %global_index)
1018     {
1019       if (&uppercases (substr ($_, 0, 1)) ne $last_letter)
1020       {
1021         if ($last_letter ne '')
1022         {
1023           print INDEX_FILE "</UL></BODY></HTML>\n";
1024           close (INDEX_FILE);
1025         }
1026
1027         $last_letter = &uppercases (substr ($_, 0, 1));
1028         $initial = $last_letter;
1029         if ($initial eq '"')
1030         {
1031             $initial = "operators";
1032         }
1033         if ($initial ne '.')
1034         {
1035             open (INDEX_FILE, ">$output_dir/funcs/$initial.$fileext")
1036                 || die "couldn't write $output_dir/funcs/$initial.$fileext";
1037             print INDEX_FILE <<"EOF";
1038 <HTML><HEAD><TITLE>$initial</TITLE></HEAD>
1039 <BODY>
1040 <H2>Functions - $initial</H2>
1041 <A HREF=../funcs.$fileext TARGET=_self>[index]</A>
1042 <UL COMPACT TYPE=DISC>
1043 EOF
1044                                     ;
1045             local ($str) = "<A HREF=funcs/$initial.$fileext>[$initial]</A>";
1046             push (@output, $str);
1047             print FUNCS "$str\n";
1048         }
1049       }
1050       local ($ref);
1051       local ($is_overloaded) = ($#{$global_index {$_}} > 0 ? 1 : 0);
1052       foreach $ref (@{$global_index {$_}})
1053       {
1054           ($file, $full_file, $lineno, $column) = @{$ref};
1055           local ($symbol) = ($is_overloaded ? "$_ -  $file:$lineno" : $_);
1056           print INDEX_FILE "<LI><A HREF=../$full_file.$fileext#$lineno\_$column TARGET=main>$symbol</A>";
1057       }
1058     }
1059
1060     print INDEX_FILE "</UL></BODY></HTML>\n";
1061     close INDEX_FILE;
1062   }
1063   else
1064   {
1065     push (@output, "<UL COMPACT TYPE=DISC>");
1066     print FUNCS "<UL COMPACT TYPE=DISC>";
1067     foreach (sort {&uppercases ($a) cmp &uppercases ($b)} keys %global_index)
1068     {
1069       local ($ref);
1070       local ($is_overloaded) = ($#{$global_index {$_}} > 0 ? 1 : 0);
1071       foreach $ref (@{$global_index {$_}})
1072       {
1073           ($file, $full_file, $lineno, $column) = @{$ref};
1074           local ($symbol) = ($is_overloaded ? "$_ -  $file:$lineno" : $_);
1075           push (@output, "<LI><A HREF=$full_file.$fileext#$lineno\_$column>$symbol</A>");
1076           print FUNCS "<LI><A HREF=$full_file.$fileext#$lineno\_$column TARGET=main>$symbol</A>";
1077       }
1078     }
1079   }
1080
1081   print FUNCS &create_footer ("");
1082   close (FUNCS);
1083
1084   push (@output, "</UL>");
1085   return (@output);
1086 }
1087
1088 ######
1089 ##  Main function
1090 ######
1091
1092 local ($index_file) = 0;
1093
1094 mkdir ($output_dir, 0777)          if (! -d $output_dir);
1095 mkdir ($output_dir."/files", 0777) if (! -d $output_dir."/files");
1096 mkdir ($output_dir."/funcs", 0777) if (! -d $output_dir."/funcs");
1097
1098 &parse_prj_file ($prjfile) if ($prjfile);
1099
1100 while ($index_file <= $#list_files)
1101 {
1102   local ($file) = $list_files [$index_file];
1103
1104   if (&output_file ($file) == 0)
1105     {
1106       $list_files [$index_file] = "";
1107     }
1108   $index_file ++;
1109 }
1110 &create_index_file;
1111
1112 $indexfile = "$output_dir/index.$fileext";
1113 $indexfile =~ s!//!/!g;
1114 print "You can now download the $indexfile file to see the ",
1115   "created pages\n";