File Coverage

blib/lib/Pod/FromActionscript.pm

Criterion	Covered	Total	%
statement	170	180	94.4
branch	69	76	90.7
condition	14	18	77.7
subroutine	16	16	100.0
pod	1	1	100.0
total	270	291	92.7

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 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 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.,

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.

=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 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.

=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 = ;
      }
      else
      {
         local *IN;
         open(IN, '<', $opts->{infile})
             or croak("Failed to read file $opts->{infile}: $!\n");
         $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
         $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\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\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 $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 $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__