package Pod::FromActionscript;

use strict;
use warnings;
use Exporter;
use Carp;

our $VERSION = "0.53";
our @ISA = qw(Exporter);
our @EXPORT = qw();
our @EXPORT_OK = qw(asdoc2pod);

# Use Regexp::Common if available, but fall back to an extract from
# v2.120 if needed
our $comment_re =
    eval("local \$SIG{__WARN__} = 'DEFAULT'; local \$SIG{__DIE__} = 'DEFAULT';".
         "use Regexp::Common qw(comment); \$RE{comment}{C}")
    || qr/(?:(?:\/\*)(?:(?:[^\*]+|\*(?!\/))*)(?:\*\/))/;

=head1 NAME

Pod::FromActionscript - Convert Actionscript documentation to POD

=head1 SYNOPSIS

    use Pod::FromActionscript (asdoc2pod);
    asdoc2pod(infile => "com/clotho/Foo.as", outfile => "com.clotho.Foo.pod");
    asdoc2pod(infile => "-" outfile => "-");
    asdoc2pod(infile => \*STDIN, outfile => \*STDOUT);
    asdoc2pod(in => $ascontent, out => \$podcontent);

or use the C<asdoc2pod> command-line program included in this
distribution.

=head1 DESCRIPTION

Parse Actionscript code, searching for Javadoc-style
comments.  If any are found, convert them to POD (Perl's Plain Old
Documentation format).  The output is just the POD, unless the
C<code> flag is used, in which case the original Actionscript is
output with the Javadoc converted to POD.

Only a limited subset of Javadoc commands are understood.  See below
for the full list. Any unrecognized directives cause parsing to abort.
Future versions of this module should handle such failures more
gracefully.

=head1 LICENSE

Copyright 2005 Clotho Advanced Media, Inc., <cpan@clotho.com>

This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 FUNCTIONS

=over

=item asdoc2pod OPTIONS...

Convert Javadoc-style comments embedded in Actionscript code into POD.
The arguments are key-value pairs as follows:

=over

=item in => SCALAR

The input Actionscript code as a string.

=item infile => FILENAME

=item infile => FILEHANDLE

Read the Actionscript code from a file.  If the value is a reference,
it is assumed to be a filehandle.  If it is a scalar, it is assumed to
be a filename.  If the filename is C<->, then code is read in from
C<STDIN>.

=item out => SCALARREF

The output POD, or an empty string if no Javadoc is detected, is
assigned to the specified scalar reference.

=item outfile => FILENAME

=item outfile => FILEHANDLE

Write the POD to a file.  If there is no POD found, the no data is
written.  If the C<outfile> value is a reference, it is assumed to be a
filehandle.  If it is a scalar, it is assumed to be a filename.  If
the filename is C<->, then POD is written to C<STDOUT>.

=item verbose => BOOLEAN

If true, some debugging information is printed.  Defaults to false.

=item code => BOOLEAN

If true, then the Actionscript code is included in the output, with
the Javadoc comments replace with appropriate POD comments.  If false,
then just the POD is output, with the code omitted.  Defaults to false.

=back

=cut

sub asdoc2pod
{
   my %opts = @_;

   my $in = _get_input(\%opts);
   my $out = _convert($in, \%opts);
   _write_output($out, \%opts);
}

sub _get_input
{
   my $opts = shift;

   my $in;
   if (exists $opts->{in})
   {
      $in = $opts->{in};
   }
   elsif (exists $opts->{infile})
   {
      local $/ = undef;
      if (ref $opts->{infile})
      {
         my $infh = $opts->{infile};
         $in = <$infh>;
      }
      elsif ($opts->{infile} eq "-")
      {
         $in = <STDIN>;
      }
      else
      {
         local *IN;
         open(IN, '<', $opts->{infile})
             or croak("Failed to read file $opts->{infile}: $!\n");
         $in = <IN>;
         close(IN);
      }
   }
   else
   {
      croak("No input source specified\n");
   }
   return $in;
}

sub _write_output
{
   my $out = shift;
   my $opts = shift;

   if (exists $opts->{out})
   {
      if (ref $opts->{out})
      {
         my $var = $opts->{out};
         $$var = $out;
      }
      else
      {
         croak("The out parameter is not a reference\n");
      }
   }
   elsif ($out eq "")
   {
      # No output
   }
   elsif (exists $opts->{outfile})
   {
      if (ref $opts->{outfile})
      {
         my $of = $opts->{outfile};
         print $of $out;
      }
      elsif ($opts->{outfile} eq "-")
      {
         print STDOUT $out;
      }
      else
      {
         local *OUT;
         open(OUT, '>', $opts->{outfile})
             or croak("Failed to write file $opts->{outfile}: $!\n");
         print(OUT $out)
             or croak("Failed to write file $opts->{outfile}: $!\n");
         close(OUT)
             or croak("Failed to write file $opts->{outfile}: $!\n");
      }
   }
   else
   {
      croak("No output destination specified\n");
   }
}

sub _convert
{
   my $content = shift;
   my $opts = shift;

   if (!$opts->{code} && $content !~ /\/\*\*/)
   {
      # No javadoc included...
      return "";
   }

   my @out;
   my @parts = split /($comment_re)/, $content;
   #_diag($opts, "Got ".@parts." parts in ".length($content)." characters\n");

   my $over = 0;
   my $inapi = 0;
   foreach my $i (0..$#parts)
   {
      if ($i < $#parts && $parts[$i] =~ /^\/\*\*/)
      {
         # exclude comments like /** foo **/
         next if ($parts[$i] =~ /^\/\*\*+[^\n\*]*\*+\//);
         
         my $comment = $parts[$i];
         
         # Remove comment open and close
         $comment =~ s/^\/\*\s*//;
         $comment =~ s/\s*\*\/$//;
         
         # Unindent the comment lines
         $comment =~ s/^\s*\*[ \t]?//gm;
         
         # Convert {@code foobar} to C<foobar>
         $comment =~ s/\{\@code\s+([^\}]+)\}/C<$1>/gs;
         
         
         if ($parts[$i+1] &&
             $parts[$i+1] =~ /^\s*(?:class|interface)\s+([^\s;]+)/)
         {
            my $class = $1;
            _diag($opts, "Class: $class\n");
            
            my $descrip = "";
            my $name = _get_name(\$comment);
            my $license = _get_license(\$comment);
            my $author = _get_author(\$comment);
            my $sees = _get_sees(\$comment);
            if ($comment =~ /\S/)
            {
               $descrip = "=head1 DESCRIPTION\n\n$comment\n\n";
            }
            $comment = "$name$descrip$sees$license$author";
            
            $inapi = 0;
         }
         elsif ($parts[$i+1] && 
                $parts[$i+1] =~ /^\s*((?:public|private)\s+|)(static\s+|)function\s+(\w+)\s*\(([^\)]*)\)(:\w+|)/)
         {
            my $private = $1;
            my $static = $2;
            my $fname = $3;
            my $args = $4;
            my $ftype = $5;
            $private = $private =~ /private/;
            $static = $static =~ /static/;
            
            if (!$inapi)
            {
               $inapi = 1;
               $parts[$i-1] .= "/*\n\n=head1 API\n\n=cut\n*/\n";
               push @out, "=head1 API\n\n";
            }
            if (!$over)
            {
               $over++;
               $parts[$i-1] .= "/*\n\n=over\n\n=cut\n*/\n";
               push @out, "=over\n\n";
            }
            
            _diag($opts, "Function: ".($private?"private ":"").($static?"static ":"")."function $fname($args)$ftype\n");
            
            my ($paramlist, $params) = _get_params(\$comment); 
            my $returns = _get_returns(\$comment); 
            my $sees = _get_sees(\$comment); 
            
            $comment = "=item $fname$paramlist\n\n$params$comment\n\n$returns$sees";
         }
         elsif ($parts[$i+1] && 
                $parts[$i+1] =~ /^\s*((?:public|private)\s+|)(static\s+|)var\s+(\w+)(:\w+|)(\s*=\s*[^;]+|)/)
         {
            my $private = $1;
            my $static = $2;
            my $vname = $3;
            my $vtype = $4;
            my $default = $5;
            $private = $private =~ /private/;
            $static = $static =~ /static/;
            
            $default =~ s/^\s*=\s*//;
            if ($default ne "")
            {
               $default = "B<Default value:> $default\n\n";
            }
            
            if (!$inapi)
            {
               $inapi = 1;
               $parts[$i-1] .= "/*\n\n=head1 API\n\n=cut\n*/\n";
               push @out, "=head1 API\n\n";
            }
            if (!$over)
            {
               $over++;
               $parts[$i-1] .= "/*\n\n=over\n\n=cut\n*/\n";
               push @out, "=over\n\n";
            }
            
            _diag($opts, "Var: ".($private?"private ":"").($static?"static ":"")."var $vname$vtype\n");
            
            my ($paramlist, $params) = _get_params(\$comment); 
            my $returns = _get_returns(\$comment); 
            my $sees = _get_sees(\$comment); 
            
            $comment = "=item $vname$paramlist\n\n$params$comment\n\n$default$returns$sees";
         }
         else
         {
            carp("Unhandled comment type\n");
         }
         
         if ($comment =~ /^=/)
         {
            $comment =~ s/\n\n\n+/\n\n/gs;
            $parts[$i] = "/*\n\n$comment=cut\n*/";
            push @out, $comment;
         }
         
         if ($parts[$i] =~ /^\s*(\@\w*)/m)
         {
            #carp("Unhandled $1 in \n$comment\n");
            carp("Unhandled $1\n");
         }
      }
   }
   if ($over > 0)
   {
      push @parts, "/*\n\n";
      for (1..$over)
      {
         push @parts, "=back\n\n";
         push @out, "=back\n\n";
      }
      push @parts, "=cut\n*/\n";
   }
   
   if (!$opts->{code} && @out == 0)
   {
      # No POD to emit
      return "";
   }
   return join("", $opts->{code} ? @parts : @out);
}

###############################################

# Extracts @param tags from comments
sub _get_params
{
   my $R_comment = shift;

   my $paramlist = "";
   my $params = "";
   while ($$R_comment =~ s/\n?[ \t]*\@param[ \t]+(\w+)(?:[ \t]*:)?[ \t]+([^\n]+)(?:\n|$)/\n/s)
   {
      my $pname = $1;
      my $pdesc = $2;
      $paramlist .= ($paramlist ? "," : "") . " $pname";
      #$params .= "=item $pname\n\n$pdesc\n\n";
      $params .= "B<$pname>: $pdesc\n\n";
   }
   #if ($params)
   #{
   #   $params = "B<Parameters:>\n\n=over\n\n" . $params . "=back\n\n";
   #}
   return ($paramlist, $params);
}

# Extracts @returns tags from comments
sub _get_returns
{
   my $R_comment = shift;

   my $returns = "";
   while ($$R_comment =~ s/\n?[ \t]*\@returns?[ \t]+([^\n]+)(?:\n|$)/\n/s)
   {
      my $rdesc = $1;
      $returns .= "B<Returns:> $rdesc\n\n";
   }
   return $returns;
}

# Extracts @see tags from comments
sub _get_sees
{
   my $R_comment = shift;

   my $sees = "";
   while ($$R_comment =~ s/\n?[ \t]*\@see[ \t]+([^\n]+)(?:\n|$)/\n/s)
   {
      my $sdesc = $1;
      $sees .= "B<See Also:> $sdesc\n\n";
   }
   return $sees;
}

# Extracts @author tags from comments
sub _get_author
{
   my $R_comment = shift;

   my $author = "";
   while ($$R_comment =~ s/\n?[ \t]*\@author[ \t]+([^\n]+)(?:\n|$)/\n/s)
   {
      my $adesc = $1;
      $author .= "=head1 AUTHOR\n\n$adesc\n\n";
   }
   return $author;
}

# Extracts @license tags from comments
sub _get_license
{
   my $R_comment = shift;

   my $license = "";
   while ($$R_comment =~ s/\n?[ \t]*\@license[ \t]*(.*?)(\n[ \t]*\@|$)/$2/s)
   {
      my $adesc = $1;
      $license .= "=head1 LICENSE\n\n$adesc\n\n";
   }
   return $license;
}

# Extracts =head1 NAME from comments
sub _get_name
{
   my $R_comment = shift;

   my $name = "";
   if ($$R_comment =~ s/^\n*([\w\.]+)[ \t]+\-[ \t]+([^\n]+)(?:\n+|$)//s)
   {
      my $title = $1;
      my $desc = $2;
      $name = "=head1 NAME\n\n$title - $desc\n\n";
   }
   return $name;
}

sub _diag
{
   my $opts = shift;
   my $msg = shift;

   warn $msg if ($opts->{verbose});
}

1;

__END__

=back

=head1 SEE ALSO

JavaDoc-style Actionscript documentation (sometimes called ASDoc)
derives from Sun's JavaDoc system.  The official JavaDoc page:
L<http://java.sun.com/j2se/javadoc/>

Here are some actively-developed non-Perl tools that can also render
Actionscript comments.  None of these do POD, but that's not always a
drawback.

=over

=item VisDoc

Commercial, Mac OSX only.  This one makes very pretty HTML output.

L<http://visiblearea.com/visdoc/>

=item as2api

Ruby, GPL (I think), cross-platform, fairly well documented.  The URL below contains links to a lot of other parsers.

L<http://www.badgers-in-foil.co.uk/projects/as2api/>

=item AS2Doc

Commercial, Windows-only.  I haven't tried it.

L<http://www.as2doc.com/>

=item AS2Docular

Free, web-based, in development (will be released "soon"), HTML
output only.  Supports Dreamweaver template syntax.

L<http://www.senocular.com/projects/AS2Docular/help.php>

=item ACID

Python, Windows only, no license specified, HTML output.  The
code is uncommented and nearly unintelligible.

L<http://icube.freezope.org/acid>

=back

=head1 COMPATIBILITY

Here is a list of all of the POD/Javadoc directives that are
understood.  I distinguish between one line directives (terminated by
a new line) and block directives (terminated by the end of the comment
or the start of a new directive.

=over

=item NAME

This is a POD-specific, one-line heuristic.  If the first line of the
comment above the class/interface declaration has a pattern like
C<E<lt>wordE<gt> - E<lt>wordsE<gt>> then it becomes a C<=head1 NAME> block.

=item DESCRIPTION

This is a POD-specific, block heuristic.  After all other ASDoc
directives have been parsed out of the comment above a class/interface
declaration, all remaining text is put in a C<=head1 DESCRIPTION>
block.

=item API

This is a POD-specific heuristic.  A C<=head1 API> block is started
just before the first function declaration.

=item FUNCTION

This is a POD-specific, block heuristic.  Each comment above a
function declaration becomes an C<=item> block.  After all ASDoc is
parsed from the comment, the remainder is added as prose below the
C<=item>.

=item PROPERTY

This is a POD-specific, block heuristic.  Each comment above a
property declaration becomes an C<=item> block.  After all ASDoc is
parsed from the comment, the remainder is added as prose below the
C<=item>.

Because a property may be a pointer to a function, all function
declaration directives are also valid in property declarations.

=item PROPERTY DEFAULT VALUE

This is a heuristic that adds a C<Default value:> comment above a
class or instance property that has an intial value set.

=item @author

This one-line directive becomes a C<=head1 AUTHOR> block.  It can only appear in a block just
above the class/interface declaration.

=item @license

This block directive becomes a C<=head1 LICENSE> block.  It can only appear in a block just
above the class/interface declaration.

=item @see

This one-line directive becomes a C<=head1 SEE ALSO> block.  It can
appear above a class/interface declaration, a function declaration or
a property declaration.

TODO: Add LE<lt>E<gt> tags around links.

=item @param

Every one-line @param directive above a function declaration becomes
an argument entry in the function comment just above any prose comments.

=item @returns

A one-line @returns directive above a function declaration becomes
a line in the function comment just below any prose comments.

=item {@code ...}

This delimited block can appear anywhere.  It is converted to a
C<CE<lt>...E<gt>> block.

=back

=head1 AUTHOR

Clotho Advanced Media Inc., I<cpan@clotho.com>

Primary developer: Chris Dolan

=cut