package SrcParser;
# This file is part of the build tools for Win32::GUI
# It encapsulates a set of functions to parse and retrieve
# documentation from within the source files.
#
# Author: Robert May , rmay@popeslane.clara.co.uk, 20 June 2005
# $Id: SrcParser.pm,v 1.6 2008/02/09 08:51:27 robertemay Exp $
use strict;
use warnings;
our $VERSION = "0.01";
our $DEBUG = 0;
# parse(@files)
# parses each file passed and "fixes" alternates that are found - see fix_alternates()
# return 1 on success
sub parse
{
  for my $file (@_) {
    parse_file($file);
  }
  fix_alternates();
  return 1;
}
# parse_file($file)
# parses the file, performing rudimentary error checking, and adding any documentation
# found to the stored data.
# dies on errors to force the documentation to be fixed
# returns 1 on success.
my %PACKAGES;
my %EVENTS;
sub parse_file
{
  my($file) = @_;
  print STDERR "Parsing file: '$file'\n" if $DEBUG;
  my $package;
  open(my $FILE, "<$file") or die "Can't open $file: $!";
  while(<$FILE>) {
    # Look for packages
    if(/\(\@\)PACKAGE:\s*(.*\S)\s*$/) {
      $package = $1;
      print STDERR "Found package: '$package'\n" if $DEBUG;
      # initialise packages structure if we haven't already seen the package
      if(not exists $PACKAGES{$package}) {
        $PACKAGES{$package} = {
                                files       => [],
                                methods     => {},
                                abstract    => '',
                                description => '',
                              };
      }
      # store the filename and linenumber where we found this package definition
      push @{$PACKAGES{$package}->{files}}, $file . "[$.]";
      # extract the package abstract and description
      # The abstract is on the line immediately following the package definition;
      # any remaining lines are package description;  We need to be careful, as
      # packages can be defined in multiple places.  Authors should take care to
      # only document the package once.  If there are multiple options, then
      # GUI.pm should be the preferred location
      my $abstract = <$FILE>;                # look at the next line
      if($abstract =~ s/^\s*(#|\*(\/)?)+\s*//) {  # if it looks like documentation, then store the abstact and description
        if($abstract) {
          die "Package $package (${file} [$.]) found a second abstract" if length $PACKAGES{$package}->{abstract} > 0;
          $PACKAGES{$package}->{abstract} = $abstract;
          # find the description:
          while(<$FILE>) {
            if( s/^\s*(#|\*(\/)?)+\s?// ) {  # if it looks like documentation, then store the description
              $PACKAGES{$package}->{description} .= ($_ eq '' ? "\n" : $_);
            }
            else {
              last;
            }
          }
        }
      }
    }
    # Look for methods
    elsif(/\(\@\)METHOD:\s*(.*\S)\s*$/) {
      my $method = $1;
      $method =~ s/\((.*)\)//;  # strip the prototype
      my $methodprototype = $1; # and store it
      $method =~ s/\s+.*//;     # strip anything after the first space - copes with "new Win32::GUI::Thing(args)
      my $methoddescr = '';
      my @alternates;
      # We have an error if there's no current package
      die "Method $method (${file} [$.]) not in a package" if not defined $package;
      print STDERR "Found method: '${package}::${method}'\n\tPrototype: $methodprototype\n" if $DEBUG;
      # We have an error if the method has already been defined
      die "Method $method (${file} [$.]) already defined in package $package"
            if exists $PACKAGES{$package}->{methods}->{$method};
      # Look at the method description
      while(<$FILE>) {
        if(/\(\@\)METHOD:\s*(.*\S)\s*$/) {
          my $alternate = $1;
          $alternate =~ s/\(.*\)//;  # remove prototype
          $alternate =~ s/\s+.*//;
          push @alternates, $alternate;
          print STDERR "\tFound alternate method in package $package: '${alternate}'\n" if $DEBUG;
        }
        elsif( s/^\s*(#|\*(\/)?)+\s?// ) {
          $methoddescr .= ($_ eq '' ? "\n" : $_);
        }
        else {
          # store the method details:
          $PACKAGES{$package}->{methods}->{$method} = {
                                                        prototype   => $methodprototype,
                                                        description => $methoddescr,
                                                        alternates  => \@alternates,
                                                      };
          last;
        }
      }
    }
    #Look for events
    elsif(/\(\@\)EVENT:\s*(.*\S)\s*$/) {
      my $event = $1;
      $event =~ s/\((.*)\)//;
      my $eventprototype = $1;
      $event =~ s/\s+.*//;
      my $eventdescr = '';
      my @packages;
      print STDERR "Found event: '$event'\n\tPrototype: $eventprototype\n" if $DEBUG;
      while(<$FILE>) {
        if(/\(\@\)APPLIES_TO:\s*(.*\S)\s*$/) {
          my $applies = $1;
          @packages = split(/\s*,\s*/, $applies);
          print STDERR "\tApplies to: $applies\n" if $DEBUG;
        }
        elsif( s/^\s*(#|\*(\/)?)+\s?// ) {
          $eventdescr .= ($_ eq '' ? "\n" : $_);
        }
        else {
          # Store the event information
          if(scalar @packages == 0) {
            die "Event $event ($file) found that applies to no packages";
          }
          # store the event against each package it applies to
          else {
            for my $pack (@packages) {
              $pack = "Win32::GUI::" . $pack unless $pack eq '*';
              # The same event has multiple legitimate definitions in different packages
              # for the same package:
              # for example, Terminate() is described in both  Window.xs and MDI.xs,
              # applying to Win32::GUI::Window package in each case.  This is nasty to
              # document, but this is my best attempt:
              # - if the defining package and applies to package are the same store under
              #   the name of the event only.
              # - if they are not, append the defining package to the hash key so that there
              #   is no collision.
              my $frompackage = defined $package ? $package : $pack;
              my $tmpevent = $event;
              if ($frompackage ne $pack) {
                $tmpevent .= " ($frompackage)";
              }
              # it's an error if we've already seen the event
              die "Event $event (${file} [$.]) alredy defined in package($pack)" if exists $EVENTS{$pack}->{$tmpevent};
              # store the event info
              $EVENTS{$pack}->{$tmpevent} = {
                                            name        => $event,
                                            prototype   => $eventprototype,
                                            description => $eventdescr,
                                            file        => $file . "[$.]",
                                         };
            }
          }
          last;
        }
      }
    }
  }
  close($FILE);
  return 1;
}
# get_package_list()
# returns a sorted list of all the packages
sub get_package_list
{
  my @tmp = sort { uc $a cmp uc $b } keys %PACKAGES;
  # Extra @tmp copy needed on perl 5.6.1 to avoid error
  # 'sort routine did not return numeric value'
  return @tmp;
}
# get_package_abstract(package)
# returns the abstract for a package
sub get_package_abstract
{
  my $package = shift;
  return $PACKAGES{$package}->{abstract};
}
# get_package_description(package)
# returns the description for a package
sub get_package_description
{
  my $package = shift;
  return $PACKAGES{$package}->{description};
}
# get_package_method_list(package)
# returns a sorted list of all the methods in a package
sub get_package_method_list
{
  my $package = shift;
  return sort newfirst keys %{$PACKAGES{$package}->{methods}};
}
# helper to sort methods: new method first, then alpha
sub newfirst
{
    return ($a =~ /^new/) ? -1 :
           ($b =~ /^new/) ? 1 : uc($a) cmp uc($b);
}
# get_package_method_prototype(package, method)
# returns the prototype of a method in a package
sub get_package_method_prototype
{
  my $package = shift;
  my $method = shift;
  return $PACKAGES{$package}->{methods}->{$method}->{prototype};
}
# get_package_method_description(package, method)
# returns the description of a method in a package
sub get_package_method_description
{
  my $package = shift;
  my $method = shift;
  return $PACKAGES{$package}->{methods}->{$method}->{description};
}
# get_common_events_list()
# returns a sorted list of all the global events
sub get_common_event_list
{
  return get_package_event_list('*');
}
# get_package_events_list(package)
# returns a sorted list of all the events associated with a package
sub get_package_event_list
{
  my $package = shift;
  return sort { lc $a cmp lc $b } keys %{$EVENTS{$package}};
}
# get_common_event_name(event)
# returns the name for the given common event
sub get_common_event_name
{
  my $event = shift;
  return get_package_event_name('*', $event);
}
# get_package_event_name(package, event)
# returns the name of a given event in a package
sub get_package_event_name
{
  my $package = shift;
  my $event = shift;
  return $EVENTS{$package}->{$event}->{name};
}
# get_common_event_prototype(event)
# returns the prototype for the given common event
sub get_common_event_prototype
{
  my $event = shift;
  return get_package_event_prototype('*', $event);
}
# get_package_event_prototype(package, event)
# returns the prototype of a given event in a package
sub get_package_event_prototype
{
  my $package = shift;
  my $event = shift;
  return $EVENTS{$package}->{$event}->{prototype};
}
# get_common_event_description(event)
# returns the raw description for the common event
sub get_common_event_description
{
  my $event = shift;
  return get_package_event_description('*', $event);
}
# get_package_event_description(package, event)
# return the raw description for an event in a package
sub get_package_event_description
{
  my $package = shift;
  my $event = shift;
  return $EVENTS{$package}->{$event}->{description};
}
# fix_alternates()
#  moves the alternate methods into the correct location, and adds text for them
# - if alternate is in same package, add it with same prototype
#   and description 'See thismethod()'
# - if package is different, add it with same prototype and description 
sub fix_alternates
{
  for my $package (keys %PACKAGES) {
    for my $method (keys %{$PACKAGES{$package}->{methods}}) {
      my $alternates = $PACKAGES{$package}->{methods}->{$method}->{alternates};
      my ($altpack, $altproto, $altdesc);
      for my $altmethod (@$alternates) {
        if ($altmethod !~ /^Win32::GUI::/) {
          $altpack = $package;
          $altproto = $PACKAGES{$package}->{methods}->{$method}->{prototype};
          $altdesc = "See $method()";
        }
        else {
          ($altpack = $altmethod) =~ s/(.*::)/$1/;
          $altproto = $PACKAGES{$package}->{methods}->{$method}->{prototype};
          $altdesc = $PACKAGES{$package}->{methods}->{$method}->{description} .
              "\n\n See also ${package}::${method}().";
        }
        die "alternate method ${altpack}::${altmethod} already defined."
            if exists $PACKAGES{$altpack}->{methods}->{$altmethod};
        # store away the details:
        $PACKAGES{$altpack}->{methods}->{$altmethod} = {
                                                        prototype   => $altproto,
                                                        description => $altdesc,
                                                      };
      }
    }
  }
  return 1;
}
1; # end of SrcParser