kalyptus/Iter.pm

   1 package Iter;
   2
   3 =head1 Iterator Module
   4
   5 A set of iterator functions for traversing the various trees and indexes.
   6 Each iterator expects closures that operate on the elements in the iterated
   7 data structure.
   8
   9
  10 =head2 Generic
  11
  12         Params: $node, &$loopsub, &$skipsub, &$applysub, &$recursesub
  13
  14 Iterate over $node\'s children. For each iteration:
  15
  16 If loopsub( $node, $kid ) returns false, the loop is terminated.
  17 If skipsub( $node, $kid )  returns true, the element is skipped.
  18
  19 Applysub( $node, $kid ) is called
  20 If recursesub( $node, $kid ) returns true, the function recurses into
  21 the current node.
  22
  23 =cut
  24
  25 sub Generic
  26 {
  27         my ( $root, $loopcond, $skipcond, $applysub, $recursecond ) = @_;
  28
  29         return sub {
  30                 foreach my $node ( @{$root->{Kids}} ) {
  31
  32                         if ( defined  $loopcond ) {
  33                                 return 0 unless $loopcond->( $root, $node );
  34                         }
  35
  36                         if ( defined $skipcond ) {
  37                                 next if $skipcond->( $root, $node );
  38                         }
  39
  40                         my $ret = $applysub->( $root, $node );
  41                         return $ret if defined $ret && $ret;
  42
  43                         if ( defined $recursecond
  44                                         && $recursecond->( $root, $node ) ) {
  45                                 $ret = Generic( $node, $loopcond, $skipcond,
  46                                                 $applysub, $recursecond)->();
  47                                 if ( $ret ) {
  48                                         return $ret;
  49                                 }
  50                         }
  51                 }
  52
  53                 return 0;
  54         };
  55 }
  56
  57 sub Class
  58 {
  59         my ( $root, $applysub, $recurse ) = @_;
  60
  61         return Generic( $root, undef,
  62                 sub {
  63                         return !( $node->{NodeType} eq "class"
  64                                 || $node->{NodeType} eq "struct" );
  65                 },
  66                 $applysub, $recurse );
  67 }
  68
  69 =head2 Tree
  70
  71         Params: $root, $recurse?, $commonsub, $compoundsub, $membersub,
  72                 $skipsub
  73
  74 Traverse the ast tree starting at $root, skipping if skipsub returns true.
  75
  76 Applying $commonsub( $node, $kid),
  77 then $compoundsub( $node, $kid ) or $membersub( $node, $kid ) depending on
  78 the Compound flag of the node.
  79
  80 =cut
  81
  82 sub Tree
  83 {
  84         my ( $rootnode, $recurse, $commonsub, $compoundsub, $membersub,
  85                  $skipsub ) = @_;
  86
  87         my $recsub = $recurse ? sub { return 1 if $_[1]->{Compound}; }
  88                                 : undef;
  89
  90         Generic( $rootnode, undef, $skipsub,
  91                 sub {                                   # apply
  92                         my ( $root, $node ) = @_;
  93                         my $ret;
  94
  95                         if ( defined $commonsub ) {
  96                                 $ret = $commonsub->( $root, $node );
  97                                 return $ret if defined $ret;
  98                         }
  99
 100                         if ( $node->{Compound} && defined $compoundsub ) {
 101                                 $ret = $compoundsub->( $root, $node );
 102                                 return $ret if defined $ret;
 103                         }
 104
 105                         if( !$node->{Compound} && defined $membersub ) {
 106                                 $ret = $membersub->( $root, $node );
 107                                 return $ret if defined $ret;
 108                         }
 109                         return;
 110                 },
 111                 $recsub                                 # skip
 112         )->();
 113 }
 114
 115 =head2 LocalCompounds
 116
 117 Apply $compoundsub( $node ) to all locally defined compound nodes
 118 (ie nodes that are not external to the library being processed).
 119
 120 =cut
 121
 122 sub LocalCompounds
 123 {
 124                 my ( $rootnode, $compoundsub ) = @_;
 125
 126                 return unless defined $rootnode && defined $rootnode->{Kids};
 127
 128                 foreach my $kid ( sort { $a->{astNodeName} cmp $b->{astNodeName} }
 129                                                                  @{$rootnode->{Kids}} ) {
 130                                 next if !defined $kid->{Compound};
 131
 132                                 $compoundsub->( $kid ) unless defined $kid->{ExtSource};
 133                                 LocalCompounds( $kid, $compoundsub );
 134                 }
 135 }
 136
 137 =head2 Hierarchy
 138
 139         Params: $node, $levelDownSub, $printSub, $levelUpSub
 140
 141 This allows easy hierarchy traversal and printing.
 142
 143 Traverses the inheritance hierarchy starting at $node, calling printsub
 144 for each node. When recursing downward into the tree, $levelDownSub($node) is
 145 called, the recursion takes place, and $levelUpSub is called when the
 146 recursion call is completed.
 147
 148 =cut
 149
 150 sub Hierarchy
 151 {
 152         my ( $node, $ldownsub, $printsub, $lupsub, $nokidssub ) = @_;
 153
 154         return if defined $node->{ExtSource}
 155                 && (!defined $node->{InBy}
 156                         || !kdocAstUtil::hasLocalInheritor( $node ));
 157
 158         $printsub->( $node );
 159
 160         if ( defined $node->{InBy} ) {
 161                 $ldownsub->( $node );
 162
 163                 foreach my $kid (
 164                                 sort {$a->{astNodeName} cmp $b->{astNodeName}}
 165                                 @{ $node->{InBy} } ) {
 166                         Hierarchy( $kid, $ldownsub, $printsub, $lupsub );
 167                 }
 168
 169                 $lupsub->( $node );
 170         }
 171         elsif ( defined $nokidssub ) {
 172                 $nokidssub->( $node );
 173         }
 174
 175         return;
 176 }
 177
 178 =head2
 179
 180         Call $printsub for each outer scope of $node.
 181
 182 =cut
 183 sub Heritage
 184 {
 185         my ( $node, $printsub ) = @_;
 186         my @anlist = ();
 187         my @heritage = kdocAstUtil::refHeritage($node);
 188
 189         foreach my $innode ( @heritage ) {
 190                 next if $innode == $node;
 191                 $printsub->( $innode, $innode->{astNodeName},
 192                         $innode->{Type}, $innode->{TmplType} )
 193                         unless !defined $printsub;
 194         }
 195
 196         return;
 197
 198 }
 199
 200 =head2
 201
 202         Call $printsub for each *direct* ancestor of $node.
 203         Only multiple inheritance can lead to $printsub being called more than once.
 204
 205 =cut
 206 sub Ancestors
 207 {
 208         my ( $node, $rootnode, $noancessub, $startsub, $printsub,
 209                 $endsub ) = @_;
 210         my @anlist = ();
 211
 212         return if $node eq $rootnode;
 213
 214         if ( !exists $node->{InList} ) {
 215                 $noancessub->( $node ) unless !defined $noancessub;
 216                 return;
 217         }
 218
 219         foreach my $innode ( @{ $node->{InList} } ) {
 220                 my $nref = $innode->{Node};     # real ancestor
 221                 next if defined $nref && $nref == $rootnode;
 222
 223                 push @anlist, $innode;
 224         }
 225
 226         if ( $#anlist < 0 ) {
 227                 $noancessub->( $node ) unless !defined $noancessub;
 228                 return;
 229         }
 230
 231         $startsub->( $node ) unless !defined $startsub;
 232
 233         foreach my $innode ( sort { $a->{astNodeName} cmp $b->{astNodeName} }
 234                                 @anlist ) {
 235
 236                 # print
 237                 $printsub->( $innode->{Node}, $innode->{astNodeName},
 238                         $innode->{Type}, $innode->{TmplType} )
 239                         unless !defined $printsub;
 240         }
 241
 242         $endsub->( $node ) unless !defined $endsub;
 243
 244         return;
 245
 246 }
 247
 248 sub Descendants
 249 {
 250         my ( $node, $nodescsub, $startsub, $printsub, $endsub ) = @_;
 251
 252         if ( !exists $node->{InBy} ) {
 253                 $nodescsub->( $node ) unless !defined $nodescsub;
 254                 return;
 255         }
 256
 257
 258         my @desclist = ();
 259         DescendantList( \@desclist, $node );
 260
 261         if ( $#desclist < 0 ) {
 262                 $nodescsub->( $node ) unless !defined $nodescsub;
 263                 return;
 264         }
 265
 266         $startsub->( $node ) unless !defined $startsub;
 267
 268         foreach my $innode ( sort { $a->{astNodeName} cmp $b->{astNodeName} }
 269                                 @desclist ) {
 270
 271                 $printsub->( $innode)
 272                         unless !defined $printsub;
 273         }
 274
 275         $endsub->( $node ) unless !defined $endsub;
 276
 277         return;
 278
 279 }
 280
 281 sub DescendantList
 282 {
 283         my ( $list, $node ) = @_;
 284
 285         return unless exists $node->{InBy};
 286
 287         foreach my $kid ( @{ $node->{InBy} } ) {
 288                 push @$list, $kid;
 289                 DescendantList( $list, $kid );
 290         }
 291 }
 292
 293 =head2 DocTree
 294
 295 =cut
 296
 297 sub DocTree
 298 {
 299         my ( $rootnode, $allowforward, $recurse,
 300                 $commonsub, $compoundsub, $membersub ) = @_;
 301
 302         Generic( $rootnode, undef,
 303                 sub {                           # skip
 304                         my( $node, $kid ) = @_;
 305
 306                         unless (!(defined $kid->{ExtSource})
 307                                         && ($allowforward || $kid->{NodeType} ne "Forward")
 308                                         && ($main::doPrivate || !($kid->{Access} =~ /private/))
 309                                         && exists $kid->{DocNode} ) {
 310
 311                                 return 1;
 312                         }
 313
 314                         return;
 315                 },
 316                 sub {                           # apply
 317                         my ( $root, $node ) = @_;
 318
 319                         my $ret;
 320
 321                         if ( defined $commonsub ) {
 322                                 $ret = $commonsub->( $root, $node );
 323                                 return $ret if defined $ret;
 324                         }
 325
 326                         if ( $node->{Compound} && defined $compoundsub ) {
 327                                 $ret = $compoundsub->( $root, $node );
 328                                 return $ret if defined $ret;
 329                         }
 330                         elsif( defined $membersub ) {
 331                                 $ret = $membersub->( $root, $node );
 332                                 return $ret if defined $ret;
 333                         }
 334
 335                         return;
 336                 },
 337                 sub { return 1 if $recurse; return; }   # recurse
 338                 )->();
 339
 340 }
 341
 342 sub MembersByType
 343 {
 344         my ( $node, $startgrpsub, $methodsub, $endgrpsub, $nokidssub ) = @_;
 345
 346 # public
 347         # types
 348         # data
 349         # methods
 350         # signals
 351         # slots
 352         # static
 353 # protected
 354 # private (if enabled)
 355
 356         if ( !defined $node->{Kids} ) {
 357                         $nokidssub->( $node ) if defined $nokidssub;
 358                         return;
 359         }
 360
 361         foreach my $acc ( qw/public protected private/ ) {
 362                 next if $acc eq "private" && !$main::doPrivate;
 363                 $access = $acc;
 364
 365                 my @types = ();
 366                 my @data = ();
 367                 my @signals = ();
 368                 my @k_dcops = ();
 369                 my @k_dcop_signals = ();
 370                 my @k_dcop_hiddens = ();
 371                 my @slots =();
 372                 my @methods = ();
 373                 my @static = ();
 374                 my @modules = ();
 375                 my @interfaces = ();
 376
 377                 # Build lists
 378                 foreach my $kid ( @{$node->{Kids}} ) {
 379                         next unless ( $kid->{Access} =~ /$access/
 380                                   && !$kid->{ExtSource})
 381                                  || ( $access eq "public"
 382                                     && ( $kid->{Access} eq "signals"
 383                                       || $kid->{Access} =~ "k_dcop" # note the =~
 384                   || $kid->{Access} eq "K_DCOP"));
 385
 386                         my $type = $kid->{NodeType};
 387
 388                         if ( $type eq "method" ) {
 389                                 if ( $kid->{Flags} =~ "s" ) {
 390                                         push @static, $kid;
 391                                 }
 392                                 elsif ( $kid->{Flags} =~ "l" ) {
 393                                         push @slots, $kid;
 394                                 }
 395                                 elsif ( $kid->{Flags} =~ "n" ) {
 396                                         push @signals, $kid;
 397                                 }
 398                                 elsif ( $kid->{Flags} =~ "d" ) {
 399                                         push @k_dcops, $kid;
 400                                 }
 401                                 elsif ( $kid->{Flags} =~ "z" ) {
 402                                         push @k_dcop_signals, $kid;
 403                                 }
 404                                 elsif ( $kid->{Flags} =~ "y" ) {
 405                                         push @k_dcop_hiddens, $kid;
 406                                 }
 407                                 else {
 408                                         push @methods, $kid; }
 409                         }
 410                         elsif ( $kid->{Compound} ) {
 411                                 if ( $type eq "module" ) {
 412                                         push @modules, $kid;
 413                                 }
 414                                 elsif ( $type eq "interface" ) {
 415                                         push @interfaces, $kid;
 416                                 }
 417                                 else {
 418                                         push @types, $kid;
 419                                 }
 420                         }
 421                         elsif ( $type eq "typedef" || $type eq "enum" ) {
 422                                 push @types, $kid;
 423                         }
 424                         else {
 425                                 push @data, $kid;
 426                         }
 427                 }
 428
 429                 # apply
 430                 $uc_access = ucfirst( $access );
 431
 432                 doGroup( "$uc_access Types", $node, \@types, $startgrpsub,
 433                         $methodsub, $endgrpsub);
 434                 doGroup( "Modules", $node, \@modules, $startgrpsub,
 435                         $methodsub, $endgrpsub);
 436                 doGroup( "Interfaces", $node, \@interfaces, $startgrpsub,
 437                         $methodsub, $endgrpsub);
 438                 doGroup( "$uc_access Methods", $node, \@methods, $startgrpsub,
 439                         $methodsub, $endgrpsub);
 440                 doGroup( "$uc_access Slots", $node, \@slots, $startgrpsub,
 441                         $methodsub, $endgrpsub);
 442                 doGroup( "Signals", $node, \@signals, $startgrpsub,
 443                         $methodsub, $endgrpsub);
 444                 doGroup( "k_dcop", $node, \@k_dcops, $startgrpsub,
 445                         $methodsub, $endgrpsub);
 446                 doGroup( "k_dcop_signals", $node, \@k_dcop_signals, $startgrpsub,
 447                         $methodsub, $endgrpsub);
 448                 doGroup( "k_dcop_hiddens", $node, \@k_dcop_hiddens, $startgrpsub,
 449                         $methodsub, $endgrpsub);
 450                 doGroup( "$uc_access Static Methods", $node, \@static,
 451                         $startgrpsub, $methodsub, $endgrpsub);
 452                 doGroup( "$uc_access Members", $node, \@data, $startgrpsub,
 453                         $methodsub, $endgrpsub);
 454         }
 455 }
 456
 457 sub doGroup
 458 {
 459         my ( $name, $node, $list, $startgrpsub, $methodsub, $endgrpsub ) = @_;
 460
 461         my ( $hasMembers ) = 0;
 462         foreach my $kid ( @$list ) {
 463                 if ( !exists $kid->{DocNode}->{Reimplemented} ) {
 464                         $hasMembers = 1;
 465                         break;
 466                 }
 467         }
 468         return if !$hasMembers;
 469
 470         if ( defined $methodsub ) {
 471                 foreach my $kid ( @$list ) {
 472                         if ( !exists $kid->{DocNode}->{Reimplemented} ) {
 473                                 $methodsub->( $node, $kid );
 474                         }
 475                 }
 476         }
 477
 478         $endgrpsub->( $name ) if defined $endgrpsub;
 479 }
 480
 481 sub ByGroupLogical
 482 {
 483         my ( $root, $startgrpsub, $itemsub, $endgrpsub ) = @_;
 484
 485         return 0 unless defined $root->{Groups};
 486
 487         foreach my $groupname ( sort keys %{$root->{Groups}} ) {
 488                 next if $groupname eq "astNodeName"||$groupname eq "NodeType";
 489
 490                 my $group = $root->{Groups}->{ $group };
 491                 next unless $group->{Kids};
 492
 493                 $startgrpsub->( $group->{astNodeName}, $group->{Desc} );
 494
 495                 foreach my $kid (sort {$a->{astNodeName} cmp $b->{astNodeName}}
 496                                         @group->{Kids} ) {
 497                         $itemsub->( $root, $kid );
 498                 }
 499                 $endgrpsub->( $group->{Desc} );
 500         }
 501
 502         return 1;
 503 }
 504
 505 sub SeeAlso
 506 {
 507         my ( $node, $nonesub, $startsub, $printsub, $endsub ) = @_;
 508
 509         if( !defined $node ) {
 510                 $nonesub->();
 511                 return;
 512         }
 513
 514         my $doc = $node;
 515
 516         if ( $node->{NodeType} ne "DocNode" ) {
 517                 $doc = $node->{DocNode};
 518                 if ( !defined $doc ) {
 519                         $nonesub->() if defined $nonesub;
 520                         return;
 521                 }
 522         }
 523
 524         if ( !defined $doc->{See} ) {
 525                 $nonesub->() if defined $nonesub;
 526                 return;
 527         }
 528
 529         my $see = $doc->{See};
 530         my $ref = $doc->{SeeRef};
 531
 532         if ( $#$see < 1 ) {
 533                 $nonesub->() if defined $nonesub;
 534                 return;
 535         }
 536
 537         $startsub->( $node ) if defined $startsub;
 538
 539         for my $i ( 0..$#$see ) {
 540                 my $seelabel = $see->[ $i ];
 541                 my $seenode = undef;
 542                 if ( defined $ref ) {
 543                         $seenode = $ref->[ $i ];
 544                 }
 545
 546                 $printsub->( $seelabel, $seenode ) if defined $printsub;
 547         }
 548
 549         $endsub->( $node ) if defined $endsub;
 550
 551         return;
 552 }
 553
 554 1;