GPL_bin_fullset/NaturalDocs/Modules/NaturalDocs/Languages/Tcl.pm

   1 ###############################################################################
   2 #
   3 #   Class: NaturalDocs::Languages::Tcl
   4 #
   5 ###############################################################################
   6 #
   7 #   A subclass to handle the language variations of Tcl.
   8 #
   9 ###############################################################################
  10
  11 # This file is part of Natural Docs, which is Copyright © 2003-2010 Greg Valure
  12 # Natural Docs is licensed under version 3 of the GNU Affero General Public License (AGPL)
  13 # Refer to License.txt for the complete details
  14
  15 use strict;
  16 use integer;
  17
  18 package NaturalDocs::Languages::Tcl;
  19
  20 use base 'NaturalDocs::Languages::Simple';
  21
  22
  23 #
  24 #   bool: pastFirstBrace
  25 #
  26 #   Whether we've past the first brace in a function prototype or not.
  27 #
  28 my $pastFirstBrace;
  29
  30
  31 #
  32 #   Function: OnCode
  33 #
  34 #   This is just overridden to reset <pastFirstBrace>.
  35 #
  36 sub OnCode #(...)
  37     {
  38     my ($self, @params) = @_;
  39
  40     $pastFirstBrace = 0;
  41
  42     return $self->SUPER::OnCode(@params);
  43     };
  44
  45
  46 #
  47 #   Function: OnPrototypeEnd
  48 #
  49 #   Tcl's function syntax is shown below.
  50 #
  51 #   > proc [name] { [params] } { [code] }
  52 #
  53 #   The opening brace is one of the prototype enders.  We need to allow the first opening brace because it contains the
  54 #   parameters.
  55 #
  56 #   Also, the parameters may have braces within them.  I've seen one that used { seconds 20 } as a parameter.
  57 #
  58 #   Parameters:
  59 #
  60 #       type - The <TopicType> of the prototype.
  61 #       prototypeRef - A reference to the prototype so far, minus the ender in dispute.
  62 #       ender - The ender symbol.
  63 #
  64 #   Returns:
  65 #
  66 #       ENDER_ACCEPT - The ender is accepted and the prototype is finished.
  67 #       ENDER_IGNORE - The ender is rejected and parsing should continue.  Note that the prototype will be rejected as a whole
  68 #                                  if all enders are ignored before reaching the end of the code.
  69 #       ENDER_ACCEPT_AND_CONTINUE - The ender is accepted so the prototype may stand as is.  However, the prototype might
  70 #                                                          also continue on so continue parsing.  If there is no accepted ender between here and
  71 #                                                          the end of the code this version will be accepted instead.
  72 #       ENDER_REVERT_TO_ACCEPTED - The expedition from ENDER_ACCEPT_AND_CONTINUE failed.  Use the last accepted
  73 #                                                        version and end parsing.
  74 #
  75 sub OnPrototypeEnd #(type, prototypeRef, ender)
  76     {
  77     my ($self, $type, $prototypeRef, $ender) = @_;
  78
  79     if ($type eq ::TOPIC_FUNCTION() && $ender eq '{' && !$pastFirstBrace)
  80         {
  81         $pastFirstBrace = 1;
  82         return ::ENDER_IGNORE();
  83         }
  84     else
  85         {  return ::ENDER_ACCEPT();  };
  86     };
  87
  88
  89 #
  90 #   Function: ParsePrototype
  91 #
  92 #   Parses the prototype and returns it as a <NaturalDocs::Languages::Prototype> object.
  93 #
  94 #   Parameters:
  95 #
  96 #       type - The <TopicType>.
  97 #       prototype - The text prototype.
  98 #
  99 #   Returns:
 100 #
 101 #       A <NaturalDocs::Languages::Prototype> object.
 102 #
 103 sub ParsePrototype #(type, prototype)
 104     {
 105     my ($self, $type, $prototype) = @_;
 106
 107     if ($type ne ::TOPIC_FUNCTION())
 108         {
 109         my $object = NaturalDocs::Languages::Prototype->New($prototype);
 110         return $object;
 111         };
 112
 113
 114     # Parse the parameters out of the prototype.
 115
 116     my @tokens = $prototype =~ /([^\{\}\ ]+|.)/g;
 117
 118     my $parameter;
 119     my @parameterLines;
 120
 121     my $braceLevel = 0;
 122
 123     my ($beforeParameters, $afterParameters, $finishedParameters);
 124
 125     foreach my $token (@tokens)
 126         {
 127         if ($finishedParameters)
 128             {  $afterParameters .= $token;  }
 129
 130         elsif ($token eq '{')
 131             {
 132             if ($braceLevel == 0)
 133                 {  $beforeParameters .= $token;  }
 134
 135             else # braceLevel > 0
 136                 {  $parameter .= $token;   };
 137
 138             $braceLevel++;
 139             }
 140
 141         elsif ($token eq '}')
 142             {
 143             if ($braceLevel == 1)
 144                 {
 145                 if ($parameter && $parameter ne ' ')
 146                     {  push @parameterLines, $parameter;  };
 147
 148                 $finishedParameters = 1;
 149                 $afterParameters .= $token;
 150
 151                 $braceLevel--;
 152                 }
 153             elsif ($braceLevel > 1)
 154                 {
 155                 $parameter .= $token;
 156                 $braceLevel--;
 157                 };
 158             }
 159
 160         elsif ($token eq ' ')
 161             {
 162             if ($braceLevel == 1)
 163                 {
 164                 if ($parameter)
 165                     {  push @parameterLines, $parameter;  };
 166
 167                 $parameter = undef;
 168                 }
 169             elsif ($braceLevel > 1)
 170                 {
 171                 $parameter .= $token;
 172                 }
 173             else
 174                 {
 175                 $beforeParameters .= $token;
 176                 };
 177             }
 178
 179         else
 180             {
 181             if ($braceLevel > 0)
 182                 {  $parameter .= $token;  }
 183             else
 184                 {  $beforeParameters .= $token;  };
 185             };
 186         };
 187
 188     foreach my $part (\$beforeParameters, \$afterParameters)
 189         {
 190         $$part =~ s/^ //;
 191         $$part =~ s/ $//;
 192         };
 193
 194     my $prototypeObject = NaturalDocs::Languages::Prototype->New($beforeParameters, $afterParameters);
 195
 196
 197     # Parse the actual parameters.
 198
 199     foreach my $parameterLine (@parameterLines)
 200         {
 201         $prototypeObject->AddParameter( $self->ParseParameterLine($parameterLine) );
 202         };
 203
 204     return $prototypeObject;
 205     };
 206
 207
 208 #
 209 #   Function: ParseParameterLine
 210 #
 211 #   Parses a prototype parameter line and returns it as a <NaturalDocs::Languages::Prototype::Parameter> object.
 212 #
 213 sub ParseParameterLine #(line)
 214     {
 215     my ($self, $line) = @_;
 216     return NaturalDocs::Languages::Prototype::Parameter->New(undef, undef, $line, undef, undef, undef);
 217     };
 218
 219
 220 1;