bin/makedoc.pl

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use XML::LibXML;
   5 use XML::XPath;
   6 use XML::XPath::XMLParser;
   7
   8 my $xp = XML::XPath->new(filename => $ARGV[0]);
   9 my $format = $ARGV[1];
  10 my $only_class = $ARGV[2];
  11
  12
  13 #my $suffix = defined $format ? '.'.$format : '.txt';
  14 my $suffix = '.pod';
  15
  16 # Get the dia objects in this file
  17 my $objectset     = $xp->find('/dia:diagram/dia:layer/dia:object[@type=\'UML - Class\' or '.
  18                               '@type=\'UML - LargePackage\']');
  19 my $classset      = $xp->find('/dia:diagram/dia:layer/dia:object[@type=\'UML - Class\']');
  20 my $objecttypeset = $xp->find('/dia:diagram/dia:layer/dia:object[@type=\'UML - Class\' or '.
  21                               '@type=\'UML - LargePackage\']/@type');
  22 my $positionset   = $xp->find('/dia:diagram/dia:layer/dia:object[@type=\'UML - Class\' or '.
  23                               '@type=\'UML - LargePackage\']/dia:attribute[@name=\'obj_pos\']/dia:point/@val');
  24 my $rectangleset  = $xp->find('/dia:diagram/dia:layer/dia:object[@type=\'UML - Class\' or '.
  25                               '@type=\'UML - LargePackage\']/dia:attribute[@name=\'obj_bb\']/dia:rectangle/@val');
  26 my $nameset       = $xp->find('/dia:diagram/dia:layer/dia:object[@type=\'UML - Class\' or '.
  27                               '@type=\'UML - LargePackage\']/dia:attribute[@name=\'name\']/dia:string/text()');
  28 my ($path_ref, $classpath_ref, $packagepath_ref) = &set_paths( $objecttypeset, $nameset, $positionset, $rectangleset );
  29 my @paths = @{$path_ref};
  30 my @classpaths = @{$classpath_ref};
  31 my @packagepaths = @{$packagepath_ref};
  32
  33
  34 system( 'export MANPATH=/users/lasse/PsN/Diagrams/doc' );
  35
  36
  37 my $i = 0;
  38 my $doc_root_path = `pwd`.'/doc';
  39 foreach my $classnode ($classset->get_nodelist) {
  40     my $nameset = $classnode->find('dia:attribute[@name=\'name\']/dia:string/text()');
  41     my @nodes = $nameset->get_nodelist;
  42     my $raw_name  = $nodes[0] -> getValue;
  43     my $name = $raw_name;
  44     $name =~ s/#//g;
  45
  46     my $attributeset = $classnode->find('dia:attribute[@name=\'name\']/dia:string[text()=\''.
  47                                         $raw_name.'\']/parent::*/parent::*/dia:attribute[@name='.
  48                                         '\'attributes\']');
  49 #                                       '\'attributes\']/dia:composite[@type=\'umlattribute\']');
  50     my $methodset = $classnode->find('dia:attribute[@name=\'name\']/dia:string[text()=\''.
  51                                      $raw_name.'\']/parent::*/parent::*/dia:attribute[@name='.
  52                                      '\'operations\']/dia:composite[@type=\'umloperation\']');
  53     my $method_name_set = $classnode->find('dia:attribute[@name=\'name\']/dia:string[text()=\''.
  54                                            $raw_name.'\']/parent::*/parent::*/dia:attribute[@name='.
  55                                            '\'operations\']/dia:composite[@type=\'umloperation\']'.
  56                                            '/dia:attribute[@name=\'name\']/dia:string/text()');
  57
  58     my %module_doc      = &get_documentation( 'lib/'.$classpaths[$i].'/'.$name.'_subs.pm',
  59                                              $doc_root_path );
  60     my ( $m_n_ref, $m_a_ref ) = &get_method_arguments( $methodset, $method_name_set );
  61     my @method_names = @{$m_n_ref};
  62     my @method_attributes = @{$m_a_ref};
  63     my $c_a_ref = &get_class_attributes( $attributeset );
  64     my @class_attributes = @{$c_a_ref};
  65
  66 #     foreach my $name ( @method_names ) {
  67 #       print "MNAME: $name \n";
  68 #     }
  69 #     foreach my $m ( @class_attributes ) {
  70 #       while ( my ($key, $value) = each %{$m}) {
  71 #           print "$key = ",join(' ',@{$value}),"\n";
  72 #       }
  73
  74 #       foreach my $row ( @{$m} ) {
  75 #           print "Aname, type, value: ", join("\t",@{$row}), "\n";
  76 #       }
  77 #    }
  78 #    die;
  79     if ( defined $classpaths[$i] and
  80          $classpaths[$i] ne '' and
  81          not -e 'doc/'.$classpaths[$i] ) {
  82         my $acc_path;
  83         foreach my $part ( split('/', $classpaths[$i]) ) {
  84             print "PART: $part \n";
  85             unless ( -e 'doc/'.$acc_path.$part ) {
  86                 mkdir 'doc/'.$acc_path.$part or die "Could not create directory doc/".$acc_path.$part,"\n"; ;
  87             }
  88             $acc_path = $acc_path.$part.'/';
  89         }
  90     }
  91
  92     open( DOC, ">doc/".$classpaths[$i].'/'.$name.$suffix );
  93
  94     print DOC "\n=begin pod\n\nUpdated ".`date`."\n=end pod\n\n";
  95     print DOC &format_name($name, $classpaths[$i], $module_doc{'include'}, $format);
  96     print DOC &format_description($module_doc{'description'}, $format) if defined $module_doc{'description'};
  97 #    print DOC &format_synopsis( $name, \@method_names, \@method_attributes, $format);
  98     print DOC &format_synopsis($module_doc{'synopsis'}, $format) if defined $module_doc{'synopsis'};
  99     print DOC &format_accessors( $name, \@class_attributes, \@method_names, $format);
 100     print DOC &format_methods( $name, \@method_names, \@method_attributes, \%module_doc, \@class_attributes, $format);
 101     print DOC &format_examples($module_doc{'examples'}, $format) if defined $module_doc{'examples'};
 102     print DOC &format_see_also($module_doc{'see_also'}, $format) if defined $module_doc{'see_also'};
 103     print DOC &format_author;
 104
 105     close( DOC );
 106     if ( $format eq 'html' ) {
 107         system( "pod2html --title ".$name." doc/".$classpaths[$i].'/'.$name.$suffix.' >doc/'.$classpaths[$i].'/'.$name.'.html' );
 108         system( "rm doc/".$classpaths[$i].'/'.$name.$suffix );
 109     }
 110     if ( $format eq 'man' ) {
 111         system( "pod2man doc/".$classpaths[$i].'/'.$name.$suffix.' >doc/'.$classpaths[$i].'/'.$name.'.man' );
 112     }
 113     $i++;
 114 }
 115
 116 sub format_accessors {
 117     my ( $class_name, $c_a_ref, $m_n_ref, $format ) = @_;
 118     my @class_attr = @{$c_a_ref};
 119     my @method_names = @{$m_n_ref};
 120     my $form_str;
 121     my @extra_names = ();
 122
 123     if ( $#class_attr >= 0 and defined $class_attr[0]->{'name'} ) {
 124         for ( my $i = 0; $i < scalar @class_attr; $i++ ){
 125             if ( defined $format and ( $format eq 'pod' or $format eq 'html' ) ) {
 126                 $form_str = "=head1 ACCESSORS\n\n";
 127             } else {
 128                 $form_str = "ACCESSORS\n\n";
 129             }
 130             foreach my $method_name ( @method_names ) {
 131                 push( @extra_names, $method_name ) if ( $method_name eq $class_attr[$i]->{'name'} );
 132                 print "Found method $method_name that matches accessor name\n" if ( $method_name eq $class_attr[$i]->{'name'} );
 133             }
 134             $form_str = $form_str.' '.$class_attr[$i]->{'name'}."\n";
 135         }
 136 #     if ( defined $class_attr{'name'} ) {
 137 #       if ( defined $format and ( $format eq 'pod' or $format eq 'html' ) ) {
 138 #           $form_str = "=head1 ACCESSORS\n\n";
 139 #       } else {
 140 #           $form_str = "ACCESSORS\n\n";
 141 #       }
 142 #       for ( my $i = 0; $i < scalar @{$class_attr{'name'}}; $i++ ){
 143 #           foreach my $method_name ( @method_names ) {
 144 #               push( @extra_names, $method_name ) if ( $method_name eq $class_attr{'name'}[$i] );
 145 #               print "Found method $method_name that matches accessor name\n" if ( $method_name eq $class_attr{'name'}[$i] );
 146 #           }
 147 #           $form_str = $form_str.' '.$class_attr{'name'}[$i]."\n";
 148 #       }
 149         $form_str = $form_str."\n";
 150         $form_str = $form_str."All class attributes should only be accessed through the attribute ".
 151             "accessors. The default behaviour of the accessors is to return the current value of ".
 152             "the attribute or to set it to a new value if an argument is given.\n\n".
 153             " \$value = $class_name -> accessor\n\n".
 154             " $class_name -> accessor( \$new_value )\n\n";
 155         if ( $#extra_names >= 0 ) {
 156             $form_str = $form_str."Accessors that do not behave like this are listed below and a ".
 157                 "description of these can be found in the L</METHODS> section\n\n";
 158             foreach my $extra_name ( @extra_names ) {
 159                 $form_str = $form_str."L</".$extra_name.">\n";
 160             }
 161             $form_str = $form_str."\n";
 162         }
 163     }
 164     return $form_str;
 165 }
 166
 167 sub format_author {
 168     return '=head1 SUPPORT/AUTHOR'."\n\n"."Copyright 2004 Lars Lindbom and Niclas Jonsson.\n".
 169         'This module is free software and comes AS IS with NO '.
 170         'WARRANTY. You may distribute the software according to the terms'.
 171         ' of the Gnu GPL.'."\n\n".'For support see the documentation and bug'.
 172         ' reports at L<http://psn.sourceforge.net>'."\n\n".
 173         'Lars Lindbom, lars.lindbom@farmbio.uu.se'."\n\n";
 174 }
 175
 176 sub format_methods {
 177     # Big sub routine, I know
 178     my ( $class_name, $m_n_ref, $m_a_ref, $m_d_ref, $c_a_ref, $format ) = @_;
 179     my @method_names = @{$m_n_ref};
 180     my @method_attributes = @{$m_a_ref};
 181     my %module_doc = %{$m_d_ref};
 182     my @class_attr = @{$c_a_ref};
 183     my $form_str;
 184
 185     if ( defined $format and ( $format eq 'pod' or $format eq 'html' ) ) {
 186         $form_str = "=head1 METHODS\n\n";
 187     } else {
 188         $form_str = "METHODS\n\n";
 189     }
 190
 191     # Constructor
 192     $form_str = $form_str."=head2 new\n\n  new(";
 193     if ( $#class_attr >= 0 and defined $class_attr[0]{'name'} ) {
 194         $form_str = $form_str.' ';
 195         for ( my $i = 0; $i <= $#class_attr; $i++ ){
 196             if ( defined $class_attr[$i]{'value'} and
 197                  $class_attr[$i]{'value'} ne '' ) {
 198                 $form_str = $form_str.'[';
 199             }
 200             $form_str = $form_str.$class_attr[$i]{'name'}.' => ';
 201             my @type = split(' ', $class_attr[$i]{'type'});
 202             if ( defined $type[0] ) {
 203                 if ( $type[0] eq 'array' ) {
 204                     $form_str = $form_str.'\@'.$type[2];
 205                 } elsif ( $type[0] eq 'hash' ) {
 206                     $form_str = $form_str.'\%'.$type[2];
 207                 } else {
 208                     $form_str = $form_str.'$'.$type[1];
 209                 }
 210             } else {
 211                 $form_str = $form_str.'undefined type';
 212             }
 213             if ( defined $class_attr[$i]{'value'} and
 214                  $class_attr[$i]{'value'} ne '' ) {
 215                 $form_str = $form_str.']';
 216             }
 217             $form_str = $form_str.",\n       " unless ( $i == $#class_attr );
 218         }
 219         $form_str = $form_str.' ';
 220     }
 221     $form_str = $form_str.')';
 222     $form_str = $form_str."\n\n";
 223     # Constructor attribute default values:
 224     if ( $#class_attr >= 0 ) {
 225         my $tmp_str;
 226         for ( my $k = 0; $k <= $#class_attr; $k++ ) {
 227             if ( defined $class_attr[$k]{'value'} and
 228                  $class_attr[$k]{'value'} ne '' ) {
 229                 $tmp_str = $tmp_str.'    '.$class_attr[$k]{'name'}.
 230                     ' ' x (40-length($class_attr[$k]{'name'})).$class_attr[$k]{'value'}."\n";
 231             }
 232         }
 233         if ( length($tmp_str) > 0 ) {
 234             $form_str = $form_str."=head3 Default values\n\n";
 235             $form_str = $form_str."$tmp_str\n";
 236         }
 237     }
 238     # Add text for constructor:
 239     if ( defined $module_doc{'new'} ) {
 240         foreach my $line ( @{$module_doc{'new'}} ) {
 241             $line =~ s/^\ //;
 242             $form_str = $form_str.$line;
 243         }
 244         $form_str = $form_str."\n\n";
 245     }
 246
 247
 248     for ( my $i = 0; $i <= $#method_names; $i++ ) {
 249         # Do not print any documenation on privat methods:
 250         next if ( $method_names[$i] =~ /^_/ );
 251         my @out_args = ();
 252         my @out_types = ();
 253         my @out_values = ();
 254         my @in_args = ();
 255         my @in_types = ();
 256         my @in_values = ();
 257         for ( my $j = 0; $j < scalar @{$method_attributes[$i]}; $j++ ) {
 258             if ( $method_attributes[$i][$j]{'kind'} == 2 ) {
 259                 push( @out_args, $method_attributes[$i][$j]{'name'} );
 260                 push( @out_types, $method_attributes[$i][$j]{'type'} );
 261                 push( @out_values, $method_attributes[$i][$j]{'value'} );
 262             } else {
 263                 push( @in_args, $method_attributes[$i][$j]{'name'} );
 264                 push( @in_types, $method_attributes[$i][$j]{'type'} );
 265                 push( @in_values, $method_attributes[$i][$j]{'value'} );
 266             }
 267         }
 268 #       for ( my $j = 0; $j < scalar @{$method_attributes[$i]{'kind'}}; $j++ ) {
 269 #           if ( $method_attributes[$i]{'kind'}[$j] == 2 ) {
 270 #               push( @out_args, $method_attributes[$i]{'name'}[$j] );
 271 #               push( @out_types, $method_attributes[$i]{'type'}[$j] );
 272 #               push( @out_values, $method_attributes[$i]{'value'}[$j] );
 273 #           } else {
 274 #               if( $method_names[$i] eq 'case_deletion' ) {
 275 #                   print "Arg name:  ",$method_attributes[$i]{'name'}[$j],"\n";
 276 #                   print "Arg value: ",$method_attributes[$i]{'value'}[$j],"\n";
 277 #                   print "Arg type:  ",$method_attributes[$i]{'type'}[$j],"\n";
 278 #               }
 279 #               push( @in_args, $method_attributes[$i]{'name'}[$j] );
 280 #               push( @in_types, $method_attributes[$i]{'type'}[$j] );
 281 #               push( @in_values, $method_attributes[$i]{'value'}[$j] );
 282 #           }
 283 #       }
 284         if ( defined $format and ( $format eq 'pod' or $format eq 'html' ) ) {
 285             $form_str = $form_str."=head2 ";
 286         } else {
 287             $form_str = $form_str."  "
 288             }
 289         $form_str = $form_str.$method_names[$i]."\n\n";
 290         if ( $#out_args >= 0 ) {
 291             if ( $#out_args >= 1 ) {
 292                 $form_str = $form_str.'  ( ';
 293                 for ( my $j = 0; $j <= $#out_args; $j++ ) {
 294                     my @type = split(' ', $out_types[$j]);
 295                     if ( $type[0] eq 'array' or $type[0] eq 'hash' ) {
 296                         $form_str = $form_str.'$'.$out_args[$j].'_ref';
 297                     } else {
 298                         $form_str = $form_str.'$'.$out_args[$j];
 299                     }
 300                     $form_str = $form_str.', ' unless ( $j == $#out_args );
 301                 }
 302                 $form_str = $form_str.' ) =';
 303 #               $form_str = $form_str.'  ( $'.join( ', $', @out_args )." ) =";
 304             } else {
 305                 my @type = split(' ', $out_types[0]);
 306                 if ( $type[0] eq 'array' or $type[0] eq 'hash' ) {
 307                     $form_str = $form_str.'  $'.$out_args[0].'_ref =';
 308                 } else {
 309                     $form_str = $form_str.'  $'.$out_args[0].' =';
 310                 }
 311 #               $form_str = $form_str.'  $'.$out_args[0]." =";
 312             }
 313         }
 314         $form_str = $form_str."\n      \$$class_name -> ".$method_names[$i];
 315         if ( $#in_args >= 0 ) {
 316             $form_str = $form_str.'( ';
 317             for ( my $k = 0; $k <= $#in_args; $k++ ) {
 318                 if ( defined $in_values[$k] and
 319                      $in_values[$k] ne '' ) {
 320                     $form_str = $form_str.'[';
 321                 }
 322                 $form_str = $form_str.$in_args[$k].' => ';
 323                 my @type = split(' ', $in_types[$k]);
 324                 if ( $type[0] eq 'array' ) {
 325                     $form_str = $form_str.'\@'.$type[2];
 326                 } elsif ( $type[0] eq 'hash' ) {
 327                     $form_str = $form_str.'\%'.$type[2];
 328                 } else {
 329                     $form_str = $form_str.'$'.$type[1];
 330                 }
 331                 if ( defined $in_values[$k] and
 332                      $in_values[$k] ne '' ) {
 333                     $form_str = $form_str.']';
 334                 }
 335                 $form_str = $form_str.",\n         ".' ' x length($class_name.' -> '.$method_names[$i]) unless ( $k == $#in_args );
 336             }
 337             $form_str = $form_str.' )';
 338         } else {
 339             $form_str = $form_str.'()';
 340         }
 341         $form_str = $form_str."\n\n";
 342         if ( $#out_args >= 0 ) {
 343             my $deref = 0;
 344             for ( my $j = 0; $j <= $#out_args; $j++ ) {
 345                 my @type = split(' ', $out_types[$j]);
 346                 if ( $type[0] eq 'array' ) {
 347                     $form_str = $form_str.'  @'.$out_args[$j].' = @{$'.$out_args[$j]."_ref}\n";
 348                     $deref++;
 349                 } elsif ( $type[0] eq 'hash' ) {
 350                     $form_str = $form_str.'  %'.$out_args[$j].' = %{$'.$out_args[$j]."_ref}\n";
 351                     $deref++;
 352                 }
 353             }
 354             $form_str = $form_str."\n\n" if $deref;
 355         }
 356         # Add the default values
 357         if ( $#in_args >= 0 ) {
 358             my $tmp_str;
 359             for ( my $k = 0; $k <= $#in_args; $k++ ) {
 360                 if ( defined $in_values[$k] and
 361                      $in_values[$k] ne '' ) {
 362                     $tmp_str = $tmp_str.'    '.$in_args[$k].
 363                         ' ' x (40-length($in_args[$k])).$in_values[$k]."\n";
 364                 }
 365             }
 366             if ( length($tmp_str) > 0 ) {
 367                 $form_str = $form_str."=head3 Default values\n\n";
 368                 $form_str = $form_str."$tmp_str\n";
 369             }
 370         }
 371
 372         # Add the text from the code
 373         if ( defined $module_doc{$method_names[$i]} ) {
 374             foreach my $line ( @{$module_doc{$method_names[$i]}} ) {
 375                 $line =~ s/^\ //;
 376                 $form_str = $form_str.$line;
 377             }
 378             $form_str = $form_str."\n\n";
 379         }
 380     }
 381     return $form_str;
 382 }
 383
 384 sub format_see_also {
 385     my $text = shift;
 386     my $format = shift;
 387     my $form_str;
 388
 389     if ( defined $format and ( $format eq 'pod' or $format eq 'html' ) ) {
 390         $form_str = "=head1 SEE ALSO\n\n";
 391         if ( defined $text ) {
 392             foreach my $line ( @{$text} ) {
 393                 $line =~ s/^ //;
 394                 $form_str = $form_str.$line;
 395             }
 396             $form_str = $form_str."\n\n";
 397         }
 398     } else {
 399         $form_str = "SEE ALSO\n\n";
 400         if ( defined $text ) {
 401             foreach my $line ( @{$text} ) {
 402                 $line =~ s/^ //;
 403                 $form_str = $form_str.$line;
 404             }
 405             $form_str = $form_str."\n\n";
 406         }
 407     }
 408     return $form_str;
 409 }
 410
 411 sub format_synopsis {
 412     my $text = shift;
 413     my $format = shift;
 414     my $form_str;
 415
 416     if ( defined $format and ( $format eq 'pod' or $format eq 'html' ) ) {
 417         $form_str = "=head1 SYNOPSIS\n\n";
 418         if ( defined $text ) {
 419             foreach my $line ( @{$text} ) {
 420                 $line =~ s/^ //;
 421                 $form_str = $form_str.$line;
 422             }
 423             $form_str = $form_str."\n\n";
 424         }
 425     } else {
 426         $form_str = "SYNOPSIS\n\n";
 427         if ( defined $text ) {
 428             foreach my $line ( @{$text} ) {
 429                 $line =~ s/^ //;
 430                 $form_str = $form_str.$line;
 431             }
 432             $form_str = $form_str."\n\n";
 433         }
 434     }
 435     return $form_str;
 436 }
 437
 438 sub format_examples {
 439     my $text = shift;
 440     my $format = shift;
 441     my $form_str;
 442
 443     if ( defined $format and ( $format eq 'pod' or $format eq 'html' ) ) {
 444         $form_str = "=head1 EXAMPLES\n\n";
 445         if ( defined $text ) {
 446             foreach my $line ( @{$text} ) {
 447                 $line =~ s/^ //;
 448                 $form_str = $form_str.$line;
 449             }
 450             $form_str = $form_str."\n\n";
 451         }
 452     } else {
 453         $form_str = "EXAMPLES\n\n";
 454         if ( defined $text ) {
 455             foreach my $line ( @{$text} ) {
 456                 $line =~ s/^ //;
 457                 $form_str = $form_str.$line;
 458             }
 459             $form_str = $form_str."\n\n";
 460         }
 461     }
 462     return $form_str;
 463 }
 464
 465 sub format_synopsis_old {
 466     my ( $class_name, $m_n_ref, $m_a_ref, $format ) = @_;
 467     my @method_names = @{$m_n_ref};
 468     my @method_attributes = @{$m_a_ref};
 469     my $form_str;
 470
 471     if ( defined $format and ( $format eq 'pod' or $format eq 'html' ) ) {
 472         $form_str = "=head1 SYNOPSIS\n\n";
 473     } else {
 474         $form_str = "SYNOPSIS\n\n";
 475     }
 476
 477     for ( my $i = 0; $i <= $#method_names; $i++ ) {
 478         if ( defined $format and ( $format eq 'pod' or $format eq 'html' ) ) {
 479             $form_str = $form_str.'  ';
 480         } else {
 481             $form_str = $form_str.'        ';
 482         }
 483         my @out_args = ();
 484         my @out_types = ();
 485         my @out_values = ();
 486         my @in_args = ();
 487         my @in_types = ();
 488         my @in_values = ();
 489         for ( my $j = 0; $j < scalar @{$method_attributes[$i]{'kind'}}; $j++ ) {
 490             if ( $method_attributes[$i]{'kind'}[$j] == 2 ) {
 491                 push( @out_args, $method_attributes[$i]{'name'}[$j] );
 492                 push( @out_types, $method_attributes[$i]{'type'}[$j] );
 493                 push( @out_values, $method_attributes[$i]{'value'}[$j] );
 494             } else {
 495                 push( @in_args, $method_attributes[$i]{'name'}[$j] );
 496                 push( @in_types, $method_attributes[$i]{'type'}[$j] );
 497                 push( @in_values, $method_attributes[$i]{'value'}[$j] );
 498             }
 499         }
 500         if ( $#out_args >= 0 ) {
 501             if ( $#out_args >= 1 ) {
 502                 $form_str = $form_str.'( $'.join( ', $', @out_args )." ) = ";
 503             } else {
 504                 $form_str = $form_str.'$'.$out_args[0]." = ";
 505             }
 506         }
 507         $form_str = $form_str."\n      \$$class_name -> ".$method_names[$i];
 508         if ( $#in_args >= 0 ) {
 509             $form_str = $form_str.'( ';
 510             for ( my $k = 0; $k <= $#in_args; $k++ ) {
 511                 if ( defined $in_values[$k] and
 512                      $in_values[$k] ne '' ) {
 513                     $form_str = $form_str.'[';
 514                 }
 515                 $form_str = $form_str.$in_args[$k].' => ';
 516                 my @type = split(' ', $in_types[$k]);
 517                 if ( $type[0] eq 'array' ) {
 518                     $form_str = $form_str.'\@'.$type[2];
 519                 } elsif ( $type[0] eq 'hash' ) {
 520                     $form_str = $form_str.'\%'.$type[2];
 521                 } else {
 522                     $form_str = $form_str.'$'.$type[1];
 523                 }
 524                 if ( defined $in_values[$k] and
 525                      $in_values[$k] ne '' ) {
 526                     $form_str = $form_str.']';
 527                 }
 528                 my $pad = length($method_names[$i])+length($class_name);
 529                 $form_str = $form_str.",\n             ".' ' x $pad unless ( $k == $#in_args );
 530             }
 531             $form_str = $form_str.' )';
 532         } else {
 533             $form_str = $form_str.'()';
 534         }
 535         $form_str = $form_str."\n\n";
 536     }
 537     $form_str = $form_str."\n";
 538     return $form_str;
 539 }
 540
 541 # Måste justeras så att undef attribut registreras, dvs som get_method_parameters
 542 sub get_class_attributes {
 543     my $attribute_set = shift;
 544     my @arguments = ( 'name', 'type', 'value' );
 545     my @attr = ();
 546 #    my %part;
 547     foreach my $attribute_node ($attribute_set->get_nodelist) {
 548         # Should be only one node in attribute_set
 549         my $part_set = $attribute_node -> find('dia:composite');
 550         foreach my $node ($part_set->get_nodelist) {
 551             my %parts = ();
 552             foreach my $arg ( @arguments ) {
 553                 my $attribute = $node -> find('dia:attribute[@name=\''.$arg.'\']'.
 554                                               '/dia:string/text()');
 555                 my @attribute_node = $attribute->get_nodelist;
 556                 # Should only be one element in @attribute_node
 557                 if ( $#attribute_node < 0 ) {
 558                     $parts{$arg} = undef;
 559 #                   print "UNDEF $arg\n";
 560                 } elsif ( $#attribute_node == 0 ) {
 561                     my $name = $attribute_node[0] -> getValue;
 562                     $name =~s/#//g;
 563                     $parts{$arg} = $name;
 564 #                   print "$arg = $name\n";
 565                 } elsif ( $#attribute_node > 0 ) {
 566                     die "Problem reading $arg nodes, too many matching\n";
 567                 }
 568             }
 569 #           my $part_set = $attribute_node -> find('dia:composite[@type=\'umlattribute\']'.
 570 #                                                  '/dia:attribute[@name=\''.$arg.'\']'.
 571 #                                                  '/dia:string/text()');
 572 #           $part{$arg} = [];
 573 #           foreach my $node ($part_set->get_nodelist) {
 574 #               my $name = $node -> getValue;
 575 #               $name =~s/#//g;
 576 #               push( @{$part{$arg}}, $name );
 577 #               print "TYPE: $arg:\t$name\n";
 578 #           }
 579             push( @attr, \%parts );
 580         }
 581     }
 582     return ( \@attr );
 583 }
 584
 585 sub get_method_arguments {
 586     my $method_set = shift;
 587     my $method_name_set = shift;
 588     my @method_names = ();
 589     my @method_attributes = ();
 590
 591     my $idx = 0;
 592     my $cd = 0;
 593     foreach my $node ($method_name_set->get_nodelist) {
 594         my $name = $node -> getValue;
 595         $name =~s/#//g;
 596         push( @method_names, $name );
 597         $cd = $idx if $name eq 'case_deletion';
 598         $idx++;
 599     }
 600
 601     $idx = 0;
 602     foreach my $method_node ($method_set->get_nodelist) {
 603         my (@attr_names, @attr_types, @attr_values) = ((),(),());
 604         my @arguments = ( 'name', 'type', 'value' );
 605         my @attr = ();
 606         my $attr_set = $method_node -> find('dia:attribute[@name=\'parameters\']/dia:composite');
 607         foreach my $node ($attr_set->get_nodelist) {
 608             my %parts = ();
 609             foreach my $arg ( @arguments ) {
 610                 my $attribute = $node -> find('dia:attribute[@name=\''.$arg.'\']'.
 611                                                   '/dia:string/text()');
 612                 my @attribute_node = $attribute->get_nodelist;
 613                 # Should only be one element in @attribute_node
 614                 if ( $#attribute_node < 0 ) {
 615                     $parts{$arg} = undef;
 616                 } elsif ( $#attribute_node == 0 ) {
 617                     my $name = $attribute_node[0] -> getValue;
 618                     $name =~s/#//g;
 619                     $parts{$arg} = $name;
 620                 } elsif ( $#attribute_node > 0 ) {
 621                     die "Problem reading $arg nodes, too many matching\n";
 622                 }
 623             }
 624             # Different handling of 'kind':
 625             my $attribute = $node -> find( 'dia:attribute[@name=\'kind\']'.
 626                                                '/dia:enum/@val');
 627             my @attribute_node = $attribute->get_nodelist;
 628             # Should only be one element in @attribute_node
 629             if ( $#attribute_node < 0 ) {
 630                 $parts{'kind'} = undef;
 631             } elsif ( $#attribute_node == 0 ) {
 632                 $parts{'kind'} = $attribute_node[0] -> getValue;
 633             } elsif ( $#attribute_node > 0 ) {
 634                 die "Problem reading kind nodes, too many matching\n";
 635             }
 636             push( @attr, \%parts );
 637         }
 638 #       foreach my $arg ( @arguments ) {
 639 #           my $attr_set = $method_node -> find('dia:attribute[@name=\'parameters\']'.
 640 #                                               '/dia:composite/dia:attribute[@name=\''.$arg.'\']'.
 641 #                                               '/dia:string/text()');
 642 #           $attr{$arg} = [];
 643 #           foreach my $node ($attr_set->get_nodelist) {
 644 #               my $name = $node -> getValue;
 645 #               $name =~s/#//g;
 646 #               push( @{$attr{$arg}}, $name );
 647 #               print "$arg\t$name\n" if $cd == $idx;
 648 #           }
 649 #       }
 650 #       # Different handling of 'kind':
 651 #       my $attr_set = $method_node -> find('dia:attribute[@name=\'parameters\']'.
 652 #                                           '/dia:composite/dia:attribute[@name=\'kind\']'.
 653 #                                           '/dia:enum/@val');
 654 #       $attr{'kind'} = [];
 655 #       foreach my $node ($attr_set->get_nodelist) {
 656 #           my $name = $node -> getValue;
 657 #           push( @{$attr{'kind'}}, $name );
 658 #       }
 659         push( @method_attributes, \@attr );
 660         $idx++;
 661     }
 662     return ( \@method_names, \@method_attributes );
 663 }
 664
 665 sub format_description {
 666     my $text = shift;
 667     my $format = shift;
 668     my $form_str;
 669
 670     if ( defined $format and ( $format eq 'pod' or $format eq 'html' ) ) {
 671         $form_str = "=head1 DESCRIPTION\n\n";
 672         if ( defined $text ) {
 673             foreach my $line ( @{$text} ) {
 674                 $line =~ s/^ //;
 675                 $form_str = $form_str.$line;
 676             }
 677             $form_str = $form_str."\n\n";
 678         }
 679     } else {
 680         $form_str = "DESCRIPTION\n\n";
 681         if ( defined $text ) {
 682             foreach my $line ( @{$text} ) {
 683                 $line =~ s/^ //;
 684                 $form_str = $form_str.$line;
 685             }
 686             $form_str = $form_str."\n\n";
 687         }
 688     }
 689     return $form_str;
 690 }
 691
 692 sub format_name {
 693     my $name = shift;
 694     my $path  = shift;
 695     my $text = shift;
 696     my $format = shift;
 697     my $form_str;
 698
 699     if ( defined $path ) {
 700         $path =~ s/\//::/g;
 701         $path = $path.'::';
 702     }
 703
 704     if ( defined $format and ( $format eq 'pod' or $format eq 'html' ) ) {
 705         $form_str = "=head1 NAME\n\n".$path.$name;
 706         if ( defined $text ) {
 707             $form_str = $form_str.' - ';
 708             foreach my $line ( @{$text} ) {
 709                 $line =~ s/^\s*//;
 710                 $form_str = $form_str.$line;
 711             }
 712         }
 713     } else {
 714         $form_str = uc($path.$name)."\n";
 715         if ( defined $text ) {
 716             foreach my $line ( @{$text} ) {
 717                 $line =~ s/^\s*//;
 718                 $form_str = $form_str.$line;
 719             }
 720         }
 721     }
 722     $form_str = $form_str."\n\n";
 723     return $form_str;
 724 }
 725
 726 sub get_documentation {
 727     my $filename = shift;
 728     my $doc_root_path = shift;
 729
 730     my %doc;
 731     open( FILE, $filename );
 732     my @file = <FILE>;
 733     close( FILE );
 734     for ( @file ) {
 735       print if /doc_root_path/;
 736       s/doc_root_path/$doc_root_path/g;
 737     }
 738     my $in_sub = 0;
 739     my $sub;
 740     foreach ( @file ) {
 741         next unless ( /^start/ or $in_sub );
 742         if ( /^start/ ) {
 743             $in_sub = 1;
 744             my @row = split;
 745             $sub = $row[1];
 746 #           print "$sub\n";
 747             next;
 748         }
 749         unless ( /^\s*\#/ or /^\s*\{/ ) {
 750             $in_sub = 0;
 751             next;
 752         }
 753         unless ( /^\s*\{/ ) {
 754             s/^\s*\#//;
 755             push( @{$doc{$sub}}, $_ );
 756         }
 757     }
 758     return %doc;
 759 }
 760
 761 sub set_paths {
 762     my ( $objecttypeset, $nameset, $positionset, $rectangleset ) = @_;
 763     my @packages = ();
 764     my @names = ();
 765     my @positions = ();
 766     my @rectangles = ();
 767
 768     foreach my $node ($objecttypeset->get_nodelist) {
 769         my $type = $node -> getValue;
 770         if ( $type eq 'UML - LargePackage' ) {
 771             push( @packages, 1 );
 772         } else {
 773             push( @packages, 0 );
 774         }
 775     }
 776
 777     foreach my $node ($nameset->get_nodelist) {
 778         my $name = $node -> getValue;
 779         $name =~s/#//g;
 780         push( @names, $name );
 781     }
 782
 783     foreach my $node ($positionset->get_nodelist) {
 784         my @position = split(',',$node -> getValue);
 785         push( @positions, \@position );
 786     }
 787
 788     foreach my $node ($rectangleset->get_nodelist) {
 789 #       print "TYPE: ",$node -> getNodeType,"\n";
 790         my @rectangle = split(/[,;]/,$node -> getValue);
 791         push( @rectangles, \@rectangle );
 792     }
 793
 794     sub find_dep {
 795         my ( $pac_ref, $names_ref, $pos_ref, $rec_ref, $only_test ) = @_;
 796         my @packages = @{$pac_ref};
 797         my @names = @{$names_ref};
 798         my @pos   = @{$pos_ref};
 799         my @bb    = @{$rec_ref};
 800
 801 #       print "Called with ",scalar @{$pos_ref}," positions\n",
 802 #       "\t",scalar @bb," rectangles and ", scalar @names," names\n";
 803 #       print "Names: @names\n";
 804 #       print "Position 0: @{$pos[0]}\n";
 805         my @paths = ();
 806         for ( my $i = 0; $i <= $#pos; $i++ ) {
 807             next if ( defined $only_test and $only_test != $i );
 808             my $width = undef;
 809             my $holding_id = undef;
 810             for ( my $j = 0; $j <= $#bb; $j++ ) {
 811                 next if ( $j == $i or not $packages[$j] );
 812                 if ( $pos[$i][0] > $bb[$j][0] and $pos[$i][0] < $bb[$j][2] and
 813                      $pos[$i][1] > $bb[$j][1] and $pos[$i][1] < $bb[$j][3] ) {
 814                     # Found a package that holds the given position
 815 #                   print "WIDTH: ",$bb[$j][2] - $bb[$j][0],"\n";
 816                     if ( not defined $width or
 817                          ($bb[$j][2] - $bb[$j][0] < $width) ) {
 818                         $width = $bb[$j][2] - $bb[$j][0];
 819                         $holding_id = $j;
 820 #                       print "YES! $names[$i] in $names[$j]\n";
 821                     }
 822                 }
 823             }
 824             if ( defined $holding_id ) {
 825                 my (@nc, @nn, @np, @nr) = ((),(),(),());
 826                 my $l = 0;
 827                 my $test_only;
 828                 for ( my $k = 0; $k <= $#names; $k++ ) {
 829                     next if ( $k == $i );
 830 #                   print "Pushing ",$names[$k],"\n";
 831                     push( @nc, $packages[$k] );
 832                     push( @nn, $names[$k] );
 833                     push( @nr, $bb[$k] );
 834                     push( @np, $pos[$k] );
 835                     $test_only = $l if ( $k == $holding_id );
 836                     $l++;
 837                 }
 838                 my @innerpath = &find_dep( \@nc, \@nn, \@np, \@nr, $test_only );
 839                 if ( defined $innerpath[0] ) {
 840                     push( @paths, $innerpath[0].'/'.$names[$holding_id] );
 841                 } else {
 842                     push( @paths, $names[$holding_id] );
 843                 }
 844 #               print "$names[$i] PATH: $paths[$#paths]\n";
 845             } else {
 846                 push( @paths, undef );
 847             }
 848         }
 849         return @paths;
 850     }
 851
 852     my @paths = &find_dep( \@packages, \@names, \@positions, \@rectangles );
 853     my ( @cl_paths, @pac_paths ) = ((),());
 854     for ( my $i = 0; $i <= $#paths; $i++ ) {
 855         if ( $packages[$i] ) {
 856             push( @pac_paths, $paths[$i] );
 857         } else {
 858             push( @cl_paths, $paths[$i] );
 859         }
 860 #       print "$packages[$i]\t$names[$i]:\t$paths[$i]\n";
 861     }
 862     return ( \@paths, \@cl_paths, \@pac_paths );
 863 }
 864
 865 die;
 866
 867
 868 # DOM TYPE specifications
 869 #         UNKNOWN_NODE (0)                The node type is unknown (not part of DOM)
 870
 871 #         ELEMENT_NODE (1)                The node is an Element.
 872 #         ATTRIBUTE_NODE (2)              The node is an Attr.
 873 #         TEXT_NODE (3)                   The node is a Text node.
 874 #         CDATA_SECTION_NODE (4)          The node is a CDATASection.
 875 #         ENTITY_REFERENCE_NODE (5)       The node is an EntityReference.
 876 #         ENTITY_NODE (6)                 The node is an Entity.
 877 #         PROCESSING_INSTRUCTION_NODE (7) The node is a ProcessingInstruction.
 878 #         COMMENT_NODE (8)                The node is a Comment.
 879 #         DOCUMENT_NODE (9)               The node is a Document.
 880 #         DOCUMENT_TYPE_NODE (10)         The node is a DocumentType.
 881 #         DOCUMENT_FRAGMENT_NODE (11)     The node is a DocumentFragment.
 882 #         NOTATION_NODE (12)              The node is a Notation.
 883
 884 #         ELEMENT_DECL_NODE (13)          The node is an ElementDecl (not part of DOM)
 885 #         ATT_DEF_NODE (14)               The node is an AttDef (not part of DOM)
 886 #         XML_DECL_NODE (15)              The node is an XMLDecl (not part of DOM)
 887 #         ATTLIST_DECL_NODE (16)          The node is an AttlistDecl (not part of DOM)
 888
 889
 890
 891
 892
 893 my $nodeset;
 894 foreach my $node ($nodeset->get_nodelist) {
 895     print "FOUND\n\n",
 896         XML::XPath::XMLParser::as_string($node),
 897         "\n\n";
 898 }
 899
 900
 901
 902 my $parser = XML::LibXML -> new;
 903
 904 my $doc = $parser -> parse_file( $ARGV[0] );
 905
 906 my $root = $doc -> getDocumentElement;
 907
 908
 909
 910
 911 #&traverse_elements( $root );
 912
 913 my @object_layer;
 914 if ( $root -> hasChildNodes ) {
 915     my @rchildren = $root -> getChildnodes;
 916     foreach my $rchild ( @rchildren ) {
 917         if ( $rchild -> getName eq 'dia:layer' and
 918              $rchild -> getAttribute( 'name' ) eq 'Background' ) {
 919             print "found Background\n";
 920             @object_layer = $rchild -> getChildnodes;
 921         }
 922     }
 923 }
 924
 925 my @classes;
 926 foreach my $perhaps_object ( @object_layer ) {
 927     if ( $perhaps_object -> getName eq 'dia:object' ) {
 928         print "Object of type ",$perhaps_object -> getAttribute( 'type' ),"\n";
 929         if ( $perhaps_object -> getAttribute( 'type' ) eq 'UML - Class' ) {
 930             push( @classes, [ $perhaps_object, &get_path( $perhaps_object, \@object_layer )] );
 931         }
 932     }
 933 }
 934
 935 sub get_attr {
 936     my $type  = shift;
 937     my $class = shift;
 938     print "type $type\n";
 939     print "TYPE: ",$class -> getAttribute('type'),"\n";
 940 #    my @attributes = $class -> getChildnodes;
 941     my @attributes = $class -> childNodes; # equiv to getChildnodes?
 942     print "ATTRIBUTES: ",scalar @attributes,"\n";
 943     my $i =1;
 944     foreach my $attr ( @attributes ) {
 945         print $i++,"\t",ref($attr),"\n";
 946         if ( ref( $attr ) eq 'XML::LibXML::Element' ) {
 947             print "NAME: ",$attr -> getAttribute( 'name' ),"\n";
 948         } elsif (ref( $attr ) eq 'XML::LibXML::Text' ) {
 949             print "TEXT: ",$attr -> textContent,"\n";
 950         }
 951         if ( ref( $attr ) eq 'XML::LibXML::Element' and
 952              $attr -> getAttribute( 'name' ) eq $type ) {
 953             my @attr_children = $attr -> getChildnodes;
 954             my $j = 1;
 955             foreach my $attrchild ( @attr_children ) {
 956                 print "Child ",$j++,"\t",ref($attrchild),"\n";
 957                 if ( ref( $attrchild ) eq 'XML::LibXML::Element' ) {
 958                     print "NAME: ",$attrchild -> getAttribute( 'name' ),"\n";
 959                     print "Value: ",$attrchild -> nodeValue,"\n";
 960                 }
 961             }
 962             print "DIA NAME: ",$attr_children[1] -> getName,"\n";
 963             if ( $attr_children[1] -> getName eq 'dia:string' ) {
 964                 print  "Value2: ",$attr_children[1] -> getValue,"\n";
 965                 return $attr_children[1] -> nodeValue;
 966             } else{
 967                 return $attr_children[1] -> getAttribute( 'val' );
 968             }
 969         }
 970     }
 971 }
 972
 973 sub get_path {
 974     my $perhaps_object = shift;
 975     my $position = &get_attr( 'obj_pos', $perhaps_object);
 976     my $obj_ref = shift;
 977     my @objects = @{$obj_ref};
 978     my @pos = split(',', $position);
 979     my $width = undef;
 980     my $inner_package = undef;
 981     foreach my $object ( @objects ) {
 982         next if $object -> isSameNode( $perhaps_object );
 983         if ( $object -> getName eq 'dia:object' and
 984              $object -> getAttribute( 'type' ) eq 'UML - LargePackage') {
 985             my @bb = split(/[,;]/,&get_attr( 'obj_bb', $object ));
 986             print "POS: ",$pos[0],',',$pos[1],"\n";
 987             print "X: ",$bb[0],',',$bb[2],"\n";
 988             print "Y: ",$bb[1],',',$bb[3],"\n";
 989             if ( $pos[0] > $bb[0] and $pos[0] < $bb[2] and
 990                  $pos[1] > $bb[1] and $pos[1] < $bb[3] ) {
 991                 # Found a package that holds the given position
 992                 print "WIDTH: ",$bb[2] - $bb[0],"\n";
 993                 if ( not defined $width or
 994                      ($bb[2] - $bb[0] < $width) ) {
 995                     $width = $bb[2] - $bb[0];
 996                     $inner_package = $object;
 997                     print "YES!\n";
 998                 }
 999             }
1000         }
1001     }
1002     my $path;
1003     if ( defined $inner_package ) {
1004         $path = &get_attr( 'name', $inner_package );
1005         print "PATH: ",$path,"\n";
1006         my $deep_path = &get_path( $inner_package, $obj_ref );
1007         $path = defined $deep_path ? $path.'/'.$deep_path : $path;
1008     }
1009     print "Returning path: $path\n";
1010     return $path;
1011 }
1012
1013
1014 print scalar @object_layer,"\n";
1015
1016 sub traverse_elements {
1017     my $elem = shift;
1018     print "REF: ",ref( $elem ),"\n";
1019 #    if ( ref( $elem ) eq 'XML::LibXML::Element' ) {
1020         print "NAME: ",$elem -> getName,"\n";
1021         print "TEXT: ",$elem -> getValue,"\n";
1022 #       print "DATA: ",$elem -> getData,"\n";
1023 #    }
1024
1025
1026     if( $elem -> hasChildNodes ) {
1027         my @children = $elem -> getChildnodes;
1028         foreach my $child ( @children ) {
1029             &traverse_elements( $child );
1030         }
1031     }
1032 }