| blib/lib/Code/Class/C.pm | |||
|---|---|---|---|
| Criterion | Covered | Total | % |
| statement | 9 | 738 | 1.2 |
| branch | 0 | 286 | 0.0 |
| condition | 0 | 96 | 0.0 |
| subroutine | 3 | 49 | 6.1 |
| pod | 12 | 14 | 85.7 |
| total | 24 | 1183 | 2.0 |
| line | stmt | bran | cond | sub | pod | time | code |
|---|---|---|---|---|---|---|---|
| 1 | package Code::Class::C; | ||||||
| 2 | |||||||
| 3 | 1 | 1 | 21584 | use 5.010000; | |||
| 1 | 4 | ||||||
| 1 | 36 | ||||||
| 4 | 1 | 1 | 6 | use strict; | |||
| 1 | 2 | ||||||
| 1 | 29 | ||||||
| 5 | 1 | 1 | 5 | use warnings; | |||
| 1 | 6 | ||||||
| 1 | 12075 | ||||||
| 6 | |||||||
| 7 | our $VERSION = '0.08'; | ||||||
| 8 | |||||||
| 9 | my $LastClassID = 0; | ||||||
| 10 | |||||||
| 11 | #------------------------------------------------------------------------------- | ||||||
| 12 | sub new | ||||||
| 13 | #------------------------------------------------------------------------------- | ||||||
| 14 | { | ||||||
| 15 | 0 | 0 | 1 | my ($class, @args) = @_; | |||
| 16 | 0 | my $self = bless {}, $class; | |||||
| 17 | 0 | return $self->_init(); | |||||
| 18 | } | ||||||
| 19 | |||||||
| 20 | #------------------------------------------------------------------------------- | ||||||
| 21 | sub func | ||||||
| 22 | #------------------------------------------------------------------------------- | ||||||
| 23 | { | ||||||
| 24 | 0 | 0 | 1 | my ($self, $name, $code) = @_; | |||
| 25 | |||||||
| 26 | 0 | my $sign = $self->_parse_signature($name); | |||||
| 27 | |||||||
| 28 | 0 | 0 | die "Error: function name '$sign->{'name'}' is not a valid function name\n" | ||||
| 29 | if $sign->{'name'} !~ /^[a-z][a-zA-Z0-9\_]*$/; | ||||||
| 30 | 0 | 0 | die "Error: function must not be named 'main'\n" | ||||
| 31 | if $sign->{'name'} eq 'main'; | ||||||
| 32 | |||||||
| 33 | 0 | $name = $self->_signature_to_string($sign); | |||||
| 34 | |||||||
| 35 | 0 | 0 | die "Error: trying to redefine function '$name'\n" | ||||
| 36 | if exists $self->{'functions'}->{$name}; | ||||||
| 37 | |||||||
| 38 | 0 | $self->{'functions'}->{$name} = $self->_load_code_from_file($code); | |||||
| 39 | 0 | 0 | $self->{'functions-doc'}->{$name} = '' | ||||
| 40 | unless exists $self->{'functions-doc'}->{$name}; | ||||||
| 41 | |||||||
| 42 | 0 | return $self; | |||||
| 43 | } | ||||||
| 44 | |||||||
| 45 | #------------------------------------------------------------------------------- | ||||||
| 46 | sub attr | ||||||
| 47 | #------------------------------------------------------------------------------- | ||||||
| 48 | { | ||||||
| 49 | 0 | 0 | 1 | my ($self, $classname, $attrname, $attrtype) = @_; | |||
| 50 | 0 | 0 | die "Error: no class '$classname' defined\n" | ||||
| 51 | unless exists $self->{'classes'}->{$classname}; | ||||||
| 52 | |||||||
| 53 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 54 | |||||||
| 55 | 0 | 0 | die "Error: attribute name '$attrname' is not a valid attribute name\n" | ||||
| 56 | if $attrname !~ /^[a-z][a-zA-Z0-9\_]*$/; | ||||||
| 57 | |||||||
| 58 | 0 | $class->{'attr'}->{$attrname} = $attrtype; | |||||
| 59 | 0 | 0 | $class->{'attr-doc'}->{$attrname} = '' | ||||
| 60 | unless exists $class->{'attr-doc'}->{$attrname}; | ||||||
| 61 | |||||||
| 62 | 0 | return $self; | |||||
| 63 | } | ||||||
| 64 | |||||||
| 65 | #------------------------------------------------------------------------------- | ||||||
| 66 | sub meth | ||||||
| 67 | #------------------------------------------------------------------------------- | ||||||
| 68 | { | ||||||
| 69 | 0 | 0 | 1 | my ($self, $classname, $name, $code) = @_; | |||
| 70 | 0 | 0 | die "Error: no class '$classname' defined\n" | ||||
| 71 | unless exists $self->{'classes'}->{$classname}; | ||||||
| 72 | |||||||
| 73 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 74 | 0 | my $sign = $self->_parse_signature($name); | |||||
| 75 | |||||||
| 76 | 0 | 0 | die "Error: failed to parse method with signature '$name'.\n" | ||||
| 77 | if !defined $sign->{'returns'}; | ||||||
| 78 | |||||||
| 79 | 0 | 0 | die "Error: methodname '$sign->{'name'}' is not a valid method name\n" | ||||
| 80 | if $sign->{'name'} !~ /^[a-z][a-zA-Z0-9\_]*$/; | ||||||
| 81 | |||||||
| 82 | # add implicit "self" first parameter | ||||||
| 83 | 0 | unshift @{$sign->{'params'}}, ['self',$classname]; | |||||
| 0 | |||||||
| 84 | 0 | $name = $self->_signature_to_string($sign); | |||||
| 85 | |||||||
| 86 | 0 | 0 | die "Error: trying to redefine method '$name' in class '$classname'\n" | ||||
| 87 | if exists $class->{'subs'}->{$name}; | ||||||
| 88 | |||||||
| 89 | 0 | $class->{'subs'}->{$name} = $self->_load_code_from_file($code); | |||||
| 90 | 0 | 0 | $class->{'subs-doc'}->{$name} = '' | ||||
| 91 | unless exists $class->{'subs-doc'}->{$name}; | ||||||
| 92 | |||||||
| 93 | 0 | return $name; | |||||
| 94 | } | ||||||
| 95 | |||||||
| 96 | #------------------------------------------------------------------------------- | ||||||
| 97 | sub parent | ||||||
| 98 | #------------------------------------------------------------------------------- | ||||||
| 99 | { | ||||||
| 100 | 0 | 0 | 1 | my ($self, $classname, @parentclassnames) = @_; | |||
| 101 | 0 | 0 | die "Error: no class '$classname' defined\n" | ||||
| 102 | unless exists $self->{'classes'}->{$classname}; | ||||||
| 103 | |||||||
| 104 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 105 | |||||||
| 106 | 0 | foreach my $parentclassname (@parentclassnames) { | |||||
| 107 | 0 | push @{$class->{'isa'}}, $parentclassname | |||||
| 0 | |||||||
| 108 | 0 | 0 | unless scalar grep { $parentclassname eq $_ } @{$class->{'isa'}}; | ||||
| 0 | |||||||
| 109 | } | ||||||
| 110 | |||||||
| 111 | 0 | return $self; | |||||
| 112 | } | ||||||
| 113 | |||||||
| 114 | #------------------------------------------------------------------------------- | ||||||
| 115 | sub before | ||||||
| 116 | #------------------------------------------------------------------------------- | ||||||
| 117 | { | ||||||
| 118 | 0 | 0 | 1 | my ($self, $classname, $methname, $code) = @_; | |||
| 119 | 0 | 0 | die "Error: no class '$classname' defined\n" | ||||
| 120 | unless exists $self->{'classes'}->{$classname}; | ||||||
| 121 | |||||||
| 122 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 123 | |||||||
| 124 | 0 | 0 | die "Error: methodname '$methname' is not a valid method name\n" | ||||
| 125 | if $methname !~ /^[a-z][a-zA-Z0-9\_]*$/; | ||||||
| 126 | |||||||
| 127 | 0 | $class->{'before'}->{$methname} = $self->_load_code_from_file($code); | |||||
| 128 | |||||||
| 129 | 0 | return $self; | |||||
| 130 | } | ||||||
| 131 | |||||||
| 132 | #------------------------------------------------------------------------------- | ||||||
| 133 | sub after | ||||||
| 134 | #------------------------------------------------------------------------------- | ||||||
| 135 | { | ||||||
| 136 | 0 | 0 | 1 | my ($self, $classname, $methname, $code) = @_; | |||
| 137 | 0 | 0 | die "Error: no class '$classname' defined\n" | ||||
| 138 | unless exists $self->{'classes'}->{$classname}; | ||||||
| 139 | |||||||
| 140 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 141 | |||||||
| 142 | 0 | 0 | die "Error: methodname '$methname' is not a valid method name\n" | ||||
| 143 | if $methname !~ /^[a-z][a-zA-Z0-9\_]*$/; | ||||||
| 144 | |||||||
| 145 | 0 | $class->{'after'}->{$methname} = $self->_load_code_from_file($code); | |||||
| 146 | |||||||
| 147 | 0 | return $self; | |||||
| 148 | } | ||||||
| 149 | |||||||
| 150 | #------------------------------------------------------------------------------- | ||||||
| 151 | sub class | ||||||
| 152 | #------------------------------------------------------------------------------- | ||||||
| 153 | { | ||||||
| 154 | 0 | 0 | 1 | my ($self, $name, %opts) = @_; | |||
| 155 | 0 | 0 | die "Error: cannot redefine class '$name': $!\n" | ||||
| 156 | if exists $self->{'classes'}->{$name}; | ||||||
| 157 | 0 | 0 | die "Error: classname '$name' does not qualify for a valid name\n" | ||||
| 158 | unless $name =~ /^[A-Z][a-zA-Z0-9\_]*$/; | ||||||
| 159 | 0 | 0 | die "Error: classname must not be 'Object'\n" | ||||
| 160 | if $name eq 'Object'; | ||||||
| 161 | 0 | 0 | die "Error: classname must not be longer than 256 characters\n" | ||||
| 162 | if length $name > 256; | ||||||
| 163 | |||||||
| 164 | 0 | $LastClassID++; | |||||
| 165 | 0 | 0 | $self->{'classes'}->{$name} = | ||||
| 0 | |||||||
| 166 | { | ||||||
| 167 | 'id' => $LastClassID, | ||||||
| 168 | 'name' => $name, | ||||||
| 169 | 'doc' => '', | ||||||
| 170 | 'isa' => [], | ||||||
| 171 | 'attr' => {}, | ||||||
| 172 | 'attr-doc' => {}, | ||||||
| 173 | 'subs' => {}, | ||||||
| 174 | 'subs-doc' => {}, | ||||||
| 175 | 'top' => ($opts{'top'} || ''), | ||||||
| 176 | 'bottom' => ($opts{'bottom'} || ''), | ||||||
| 177 | 'after' => {}, | ||||||
| 178 | }; | ||||||
| 179 | |||||||
| 180 | # define attributes | ||||||
| 181 | 0 | 0 | my $attr = $opts{'attr'} || {}; | ||||
| 182 | 0 | map { $self->attr($name, $_, $attr->{$_}) } keys %{$attr}; | |||||
| 0 | |||||||
| 0 | |||||||
| 183 | |||||||
| 184 | # define methods | ||||||
| 185 | 0 | 0 | my $subs = $opts{'subs'} || {}; | ||||
| 186 | 0 | map { $self->meth($name, $_, $subs->{$_}) } keys %{$subs}; | |||||
| 0 | |||||||
| 0 | |||||||
| 187 | |||||||
| 188 | # set parent classes | ||||||
| 189 | 0 | 0 | $self->parent($name, @{$opts{'isa'} || []}); | ||||
| 0 | |||||||
| 190 | |||||||
| 191 | 0 | return $self; | |||||
| 192 | } | ||||||
| 193 | |||||||
| 194 | #------------------------------------------------------------------------------- | ||||||
| 195 | sub readFile | ||||||
| 196 | #------------------------------------------------------------------------------- | ||||||
| 197 | { | ||||||
| 198 | 0 | 0 | 1 | my ($self, $filename) = @_; | |||
| 199 | 0 | 0 | open SRCFILE, $filename or die "Error: cannot open source file '$filename': $!\n"; | ||||
| 200 | #print "reading '$filename'\n"; | ||||||
| 201 | 0 | my $classname = undef; # if set, name of current class | |||||
| 202 | 0 | my $subname = undef; # if set, name of current method | |||||
| 203 | 0 | my $funcname = undef; # if set, name of current function | |||||
| 204 | 0 | my $top = undef; # if set, means currently parsing a @top block | |||||
| 205 | 0 | my $bottom = undef; # if set, means currently parsing a @bottom block | |||||
| 206 | 0 | my $types = undef; # if set, means currently parsing a @types block | |||||
| 207 | 0 | my $after = undef; # if set, the method name for current @after block | |||||
| 208 | 0 | my $before = undef; # if set, the method name for current @before block | |||||
| 209 | |||||||
| 210 | 0 | my $buffer = undef; | |||||
| 211 | 0 | my $l = 0; | |||||
| 212 | 0 | my $docref = undef; # ref to docstring of previous entry | |||||
| 213 | 0 | while ( |
|||||
| 214 | 0 | 0 | next if /^\/[\/\*]/; | ||||
| 215 | 0 | 0 | 0 | if (/^\@class/) { | |||
| 0 | 0 | ||||||
| 0 | 0 | ||||||
| 0 | |||||||
| 0 | |||||||
| 0 | |||||||
| 0 | |||||||
| 0 | |||||||
| 0 | |||||||
| 0 | |||||||
| 216 | 0 | my ($class, $parents) = | |||||
| 217 | $_ =~ /^\@class[\s\t]+([^\s\t\:]+)[\s\t]*\:?[\s\t]*(.*)$/; | ||||||
| 218 | 0 | my @parents = split /[\s\t]*\,[\s\t]*/, $parents; | |||||
| 219 | |||||||
| 220 | 0 | 0 | $self->class($class) unless exists $self->{'classes'}->{$class}; | ||||
| 221 | 0 | $self->parent($class, @parents); | |||||
| 222 | 0 | $classname = $class; | |||||
| 223 | 0 | $docref = \$self->{'classes'}->{$class}->{'doc'}; | |||||
| 224 | } | ||||||
| 225 | elsif (/^\@attr/) { | ||||||
| 226 | 0 | 0 | die "Error: no classname present at line $l.\n" | ||||
| 227 | unless defined $classname; | ||||||
| 228 | |||||||
| 229 | 0 | my ($attr, $type) = | |||||
| 230 | $_ =~ /^\@attr[\s\t]+([^\s\t\:]+)[\s\t]*\:?[\s\t]*(.*)$/; | ||||||
| 231 | 0 | $type =~ s/[\s\t\n\r]*$//g; | |||||
| 232 | |||||||
| 233 | 0 | 0 | warn "Warning: attribute definition $classname/$attr overwrites present one.\n" | ||||
| 234 | if exists $self->{'classes'}->{$classname}->{'attr'}->{$attr}; | ||||||
| 235 | |||||||
| 236 | 0 | $self->attr($classname, $attr, $type); | |||||
| 237 | |||||||
| 238 | 0 | 0 | $self->{'classes'}->{$classname}->{'attr-doc'}->{$attr} = '' | ||||
| 239 | unless exists $self->{'classes'}->{$classname}->{'attr-doc'}->{$attr}; | ||||||
| 240 | 0 | $docref = \$self->{'classes'}->{$classname}->{'attr-doc'}->{$attr}; | |||||
| 241 | } | ||||||
| 242 | elsif (/^\@(sub|func|before|after)/) { | ||||||
| 243 | 0 | 0 | unless (/^\@func/) { | ||||
| 244 | 0 | 0 | die "Error: no classname present at line $l.\n" | ||||
| 245 | unless defined $classname; | ||||||
| 246 | } | ||||||
| 247 | |||||||
| 248 | # save previous "something" | ||||||
| 249 | 0 | _save_current_buffer($self, $classname, $subname, $funcname, $before, $after, $buffer); | |||||
| 250 | |||||||
| 251 | # start new "something" | ||||||
| 252 | 0 | 0 | if (/^\@sub/) { | ||||
| 0 | |||||||
| 0 | |||||||
| 0 | |||||||
| 253 | 0 | ($subname) = $_ =~ /^\@sub[\s\t]+(.+)[\s\t\n\r]*$/; | |||||
| 254 | 0 | $funcname = undef; | |||||
| 255 | 0 | $before = undef; | |||||
| 256 | 0 | $after = undef; | |||||
| 257 | |||||||
| 258 | 0 | my $methname = $self->_get_complete_method_name($classname, $subname); | |||||
| 259 | #print "($methname)\n" if $methname =~ /^getAppWindow/; | ||||||
| 260 | 0 | 0 | $self->{'classes'}->{$classname}->{'subs-doc'}->{$methname} = '' | ||||
| 261 | unless exists $self->{'classes'}->{$classname}->{'subs-doc'}->{$methname}; | ||||||
| 262 | #print ">>docref meth $methname\n"; | ||||||
| 263 | 0 | $docref = \$self->{'classes'}->{$classname}->{'subs-doc'}->{$methname}; | |||||
| 264 | } | ||||||
| 265 | elsif (/^\@func/) { | ||||||
| 266 | 0 | ($funcname) = $_ =~ /^\@func[\s\t]+(.+)[\s\t\n\r]*$/; | |||||
| 267 | 0 | $subname = undef; | |||||
| 268 | 0 | $before = undef; | |||||
| 269 | 0 | $after = undef; | |||||
| 270 | |||||||
| 271 | 0 | 0 | $self->{'functions-doc'}->{$funcname} = '' | ||||
| 272 | unless exists $self->{'functions-doc'}->{$funcname}; | ||||||
| 273 | 0 | $docref = \$self->{'functions-doc'}->{$funcname}; | |||||
| 274 | } | ||||||
| 275 | elsif (/^\@after/) { | ||||||
| 276 | 0 | my ($methname) = $_ =~ /^\@after[\s\t]+(.+)[\s\t\n\r]*$/; | |||||
| 277 | 0 | $after = $methname; | |||||
| 278 | 0 | $funcname = undef; | |||||
| 279 | 0 | $before = undef; | |||||
| 280 | 0 | $subname = undef; | |||||
| 281 | } | ||||||
| 282 | elsif (/^\@before/) { | ||||||
| 283 | 0 | my ($methname) = $_ =~ /^\@before[\s\t]+(.+)[\s\t\n\r]*$/; | |||||
| 284 | 0 | $before = $methname; | |||||
| 285 | 0 | $funcname = undef; | |||||
| 286 | 0 | $after = undef; | |||||
| 287 | 0 | $subname = undef; | |||||
| 288 | } | ||||||
| 289 | |||||||
| 290 | 0 | $buffer = ''; | |||||
| 291 | 0 | $bottom = undef; | |||||
| 292 | 0 | $top = undef; | |||||
| 293 | 0 | $types = undef; | |||||
| 294 | } | ||||||
| 295 | elsif (/^\@top/) { | ||||||
| 296 | 0 | $top = ''; | |||||
| 297 | 0 | $bottom = undef; | |||||
| 298 | 0 | $types = undef; | |||||
| 299 | } | ||||||
| 300 | elsif (/^\@bottom/) { | ||||||
| 301 | 0 | $bottom = ''; | |||||
| 302 | 0 | $top = undef; | |||||
| 303 | 0 | $types = undef; | |||||
| 304 | } | ||||||
| 305 | elsif (/^\@types/) { | ||||||
| 306 | 0 | $types = ''; | |||||
| 307 | 0 | $bottom = undef; | |||||
| 308 | 0 | $top = undef; | |||||
| 309 | } | ||||||
| 310 | elsif (/^[\s\t]*\@/) { | ||||||
| 311 | 0 | my ($doc) = $_ =~ /^[\s\t]*\@[\s\t]*(.*)$/; | |||||
| 312 | #print "[$doc]\n"; | ||||||
| 313 | 0 | 0 | ${$docref} .= ' '.$doc | ||||
| 0 | |||||||
| 314 | if defined $docref; | ||||||
| 315 | } | ||||||
| 316 | |||||||
| 317 | # store current line in a buffer | ||||||
| 318 | elsif (!defined $subname && defined $top) { | ||||||
| 319 | 0 | $self->{'area'}->{'top'} .= $_; | |||||
| 320 | } | ||||||
| 321 | elsif (!defined $subname && defined $bottom) { | ||||||
| 322 | 0 | $self->{'area'}->{'bottom'} .= $_; | |||||
| 323 | } | ||||||
| 324 | elsif (!defined $subname && defined $types) { | ||||||
| 325 | 0 | $self->{'area'}->{'types'} .= $_; | |||||
| 326 | } | ||||||
| 327 | else { | ||||||
| 328 | 0 | $buffer .= $_; | |||||
| 329 | } | ||||||
| 330 | 0 | $l++; | |||||
| 331 | } | ||||||
| 332 | # save last "something" | ||||||
| 333 | 0 | _save_current_buffer($self, $classname, $subname, $funcname, $before, $after, $buffer); | |||||
| 334 | |||||||
| 335 | 0 | close SRCFILE; | |||||
| 336 | 0 | return 1; | |||||
| 337 | |||||||
| 338 | sub _save_current_buffer | ||||||
| 339 | { | ||||||
| 340 | 0 | 0 | my ($self, $classname, $subname, $funcname, $before, $after, $buffer) = @_; | ||||
| 341 | 0 | 0 | 0 | if (defined $classname && defined $subname && defined $buffer) { | |||
| 0 | 0 | ||||||
| 0 | 0 | ||||||
| 0 | 0 | ||||||
| 0 | |||||||
| 0 | |||||||
| 0 | |||||||
| 342 | # add method to class | ||||||
| 343 | 0 | my $methname = $self->meth($classname, $subname, $buffer); | |||||
| 344 | } | ||||||
| 345 | elsif (defined $funcname && defined $buffer) { | ||||||
| 346 | # add function | ||||||
| 347 | 0 | $self->func($funcname, $buffer); | |||||
| 348 | } | ||||||
| 349 | elsif (defined $classname && defined $before && defined $buffer) { | ||||||
| 350 | # add 'before'-hook | ||||||
| 351 | 0 | $self->before($classname, $before, $buffer); | |||||
| 352 | } | ||||||
| 353 | elsif (defined $classname && defined $after && defined $buffer) { | ||||||
| 354 | # add 'after'-hook | ||||||
| 355 | 0 | $self->after($classname, $after, $buffer); | |||||
| 356 | } | ||||||
| 357 | } | ||||||
| 358 | |||||||
| 359 | sub _get_complete_method_name | ||||||
| 360 | { | ||||||
| 361 | 0 | 0 | my ($self, $classname, $methname) = @_; | ||||
| 362 | 0 | my $sign = $self->_parse_signature($methname); | |||||
| 363 | 0 | unshift @{$sign->{'params'}}, ['self', $classname]; | |||||
| 0 | |||||||
| 364 | 0 | return $self->_signature_to_string($sign); | |||||
| 365 | } | ||||||
| 366 | } | ||||||
| 367 | |||||||
| 368 | sub _skip_class | ||||||
| 369 | { | ||||||
| 370 | 0 | 0 | my ($classname, $classnames) = @_; | ||||
| 371 | return | ||||||
| 372 | defined $classnames && | ||||||
| 373 | 0 | 0 | !scalar grep { $_ eq $classname } @{$classnames}; | ||||
| 374 | } | ||||||
| 375 | |||||||
| 376 | #------------------------------------------------------------------------------- | ||||||
| 377 | sub functionsToLaTeX | ||||||
| 378 | #------------------------------------------------------------------------------- | ||||||
| 379 | { | ||||||
| 380 | 0 | 0 | 0 | my ($self, $autogen) = @_; | |||
| 381 | 0 | 0 | $autogen = 0 unless defined $autogen; | ||||
| 382 | |||||||
| 383 | 0 | 0 | 0 | die "Error: cannot call toLaTeX() method AFTER generate() method has been called\n" | |||
| 384 | if $autogen == 0 && $self->{'autogen'} == 1; | ||||||
| 385 | #$self->_autogen(); | ||||||
| 386 | |||||||
| 387 | 0 | my $tex = "\n\n"; | |||||
| 388 | |||||||
| 389 | 0 | 0 | if (scalar keys %{$self->{'functions'}}) { | ||||
| 0 | |||||||
| 390 | 0 | $tex .= '\subsection{Statische Funktionen}'."\n"; | |||||
| 391 | 0 | $tex .= '\begin{description*}'."\n\n"; | |||||
| 392 | 0 | foreach my $funcname (sort keys %{$self->{'functions'}}) { | |||||
| 0 | |||||||
| 393 | 0 | my $sign = $self->_parse_signature($funcname); | |||||
| 394 | 0 | my $code = $self->{'functions'}->{$funcname}; | |||||
| 395 | 0 | $code =~ s/\t/ /g; | |||||
| 396 | 0 | $code =~ s/(\r?\n)\s\s/$1/g; | |||||
| 397 | |||||||
| 398 | 0 | $tex .= | |||||
| 399 | '\item \texttt{\color{orange}'.$sign->{'name'}.'(} '. | ||||||
| 400 | join(",\n", map { | ||||||
| 401 | 0 | '\texttt{'.$_->[0].'} '.$self->_mkClassRef($_->[1]); | |||||
| 402 | 0 | } @{$sign->{'params'}}).'\texttt{\color{orange})}'. | |||||
| 403 | ': '.$self->_mkClassRef($sign->{'returns'})."\n"; | ||||||
| 404 | |||||||
| 405 | 0 | 0 | if (scalar @{$sign->{'params'}} > 0) { | ||||
| 0 | |||||||
| 406 | 0 | $tex .= "\n\n"; | |||||
| 407 | } | ||||||
| 408 | 0 | $tex .= _docToLaTeX($self->{'functions-doc'}->{$funcname})."\n\n"; | |||||
| 409 | |||||||
| 410 | # $tex .= | ||||||
| 411 | # '\item \texttt{\color{red}'.$sign->{'name'}.' ('. | ||||||
| 412 | # join(', ', map { $_->[0] } @{$sign->{'params'}}).'):} '. | ||||||
| 413 | # $self->_mkClassRef($sign->{'returns'})."\n\n"; | ||||||
| 414 | # | ||||||
| 415 | # if (scalar @{$sign->{'params'}} > 0) { | ||||||
| 416 | # $tex .= '\begin{description*}'."\n\n"; | ||||||
| 417 | # foreach my $param (@{$sign->{'params'}}) { | ||||||
| 418 | # $tex .= '\item \texttt{'.$param->[0].'} :\hspace{1ex} '.$self->_mkClassRef($param->[1])."\n\n"; | ||||||
| 419 | # } | ||||||
| 420 | # $tex .= '\end{description*}'."\n\n"; | ||||||
| 421 | # } | ||||||
| 422 | # $tex .= _docToLaTeX($self->{'functions-doc'}->{$funcname})."\n\n"; | ||||||
| 423 | # $tex .= '\vspace{3mm}'."\n\n"; | ||||||
| 424 | } | ||||||
| 425 | 0 | $tex .= '\end{description*}'."\n\n"; | |||||
| 426 | } | ||||||
| 427 | |||||||
| 428 | 0 | return $tex; | |||||
| 429 | } | ||||||
| 430 | |||||||
| 431 | #------------------------------------------------------------------------------- | ||||||
| 432 | sub toLaTeX | ||||||
| 433 | #------------------------------------------------------------------------------- | ||||||
| 434 | { | ||||||
| 435 | 0 | 0 | 0 | my ($self, $autogen, $classnames) = @_; | |||
| 436 | 0 | 0 | $autogen = 0 unless defined $autogen; | ||||
| 437 | |||||||
| 438 | 0 | 0 | 0 | die "Error: cannot call toLaTeX() method AFTER generate() method has been called\n" | |||
| 439 | if $autogen == 0 && $self->{'autogen'} == 1; | ||||||
| 440 | #$self->_autogen(); | ||||||
| 441 | |||||||
| 442 | 0 | my $tex = "\n\n"; | |||||
| 443 | 0 | foreach my $classname (keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 444 | 0 | 0 | next if _skip_class($classname,$classnames); | ||||
| 445 | 0 | $tex .= $self->_classToLaTeX($classname)."\n\n"; | |||||
| 446 | } | ||||||
| 447 | |||||||
| 448 | 0 | return $tex; | |||||
| 449 | |||||||
| 450 | sub _classToLaTeX | ||||||
| 451 | { | ||||||
| 452 | 0 | 0 | my ($self, $classname) = @_; | ||||
| 453 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 454 | 0 | my $tex = '\subsection{'.$classname."}\n"; | |||||
| 455 | 0 | $tex .= '\label{Class'.$classname."}\n"; | |||||
| 456 | |||||||
| 457 | 0 | $tex .= _docToLaTeX($self->{'classes'}->{$classname}->{'doc'})."\n"; | |||||
| 458 | 0 | $tex .= 'Die Implementierung dieser Klasse ist in der Datei \texttt{'. | |||||
| 459 | $classname.'.c} zu finden.'."\n\n"; | ||||||
| 460 | |||||||
| 461 | 0 | $tex .= '\begin{figure}[H]'."\n"; | |||||
| 462 | 0 | $tex .= ' \centering'."\n"; | |||||
| 463 | 0 | $tex .= ' \fbox{\makebox[0.5\textwidth]{'."\n"; | |||||
| 464 | 0 | $tex .= ' \includegraphics[width=0.5\textwidth,keepaspectratio]{diagrams/'.$classname.'.png}'."\n"; | |||||
| 465 | 0 | $tex .= ' }}'."\n"; | |||||
| 466 | 0 | $tex .= ' \caption{UML Klassendiagramm der Klasse '.$classname.'.}'."\n"; | |||||
| 467 | 0 | $tex .= ' \label{Block}'."\n"; | |||||
| 468 | 0 | $tex .= '\end{figure}'."\n"; | |||||
| 469 | |||||||
| 470 | 0 | 0 | if (scalar @{$class->{'isa'}}) { | ||||
| 0 | |||||||
| 471 | 0 | $tex .= '\subsubsection{Elternklassen}'."\n"; | |||||
| 472 | |||||||
| 473 | #$tex .= '\begin{itemize*}'."\n\n"; | ||||||
| 474 | #foreach my $classname (@{$class->{'isa'}}) { | ||||||
| 475 | # #$tex .= '\item '.$self->_mkClassRef($classname)."\n\n"; | ||||||
| 476 | #} | ||||||
| 477 | #$tex .= '\end{itemize*}'."\n\n"; | ||||||
| 478 | |||||||
| 479 | 0 | $tex .= join ', ', map { $self->_mkClassRef($_) } @{$class->{'isa'}}; | |||||
| 0 | |||||||
| 0 | |||||||
| 480 | 0 | $tex .= "\n\n"; | |||||
| 481 | } | ||||||
| 482 | |||||||
| 483 | 0 | my $subclasses = $self->_get_subclasses()->{$classname}; | |||||
| 484 | #use Data::Dumper; | ||||||
| 485 | #print Dumper($subclasses); | ||||||
| 486 | 0 | 0 | if (scalar keys %{$subclasses}) { | ||||
| 0 | |||||||
| 487 | 0 | $tex .= '\subsubsection{Kindklassen}'."\n"; | |||||
| 488 | #$tex .= '\begin{itemize*}'."\n\n"; | ||||||
| 489 | #foreach my $classname (keys %{$subclasses}) { | ||||||
| 490 | # $tex .= '\item '.$self->_mkClassRef($classname)."\n\n"; | ||||||
| 491 | #} | ||||||
| 492 | #$tex .= '\end{itemize*}'."\n\n"; | ||||||
| 493 | |||||||
| 494 | 0 | $tex .= join ', ', map { $self->_mkClassRef($_) } keys %{$subclasses}; | |||||
| 0 | |||||||
| 0 | |||||||
| 495 | 0 | $tex .= "\n\n"; | |||||
| 496 | } | ||||||
| 497 | |||||||
| 498 | 0 | 0 | if (scalar keys %{$class->{'attr'}}) { | ||||
| 0 | |||||||
| 499 | 0 | $tex .= '\subsubsection{Attribute}'."\n"; | |||||
| 500 | 0 | $tex .= '\begin{description*}'."\n\n"; | |||||
| 501 | 0 | foreach my $attrname (sort keys %{$class->{'attr'}}) { | |||||
| 0 | |||||||
| 502 | 0 | $tex .= '\item \texttt{\color{blue}'.$attrname.'} '.$self->_mkClassRef($class->{'attr'}->{$attrname})."\n"; | |||||
| 503 | 0 | $tex .= _docToLaTeX($class->{'attr-doc'}->{$attrname})."\n"; | |||||
| 504 | #$tex .= '\vspace{3mm}'."\n\n"; | ||||||
| 505 | } | ||||||
| 506 | 0 | $tex .= '\end{description*}'."\n\n"; | |||||
| 507 | } | ||||||
| 508 | |||||||
| 509 | 0 | 0 | if (scalar keys %{$class->{'subs'}}) { | ||||
| 0 | |||||||
| 510 | 0 | $tex .= '\subsubsection{Methoden}'."\n"; | |||||
| 511 | #$tex .= '\setlength{\parskip}{-6pt}'."\n"; | ||||||
| 512 | 0 | $tex .= '\begin{description*}'."\n\n"; | |||||
| 513 | 0 | foreach my $methname (sort keys %{$class->{'subs'}}) { | |||||
| 0 | |||||||
| 514 | 0 | my $sign = $self->_parse_signature($methname); | |||||
| 515 | 0 | my $code = $class->{'subs'}->{$methname}; | |||||
| 516 | 0 | $code =~ s/\t/ /g; | |||||
| 517 | 0 | $code =~ s/(\r?\n)\s\s/$1/g; | |||||
| 518 | 0 | $tex .= | |||||
| 519 | '\item \texttt{\color{orange}'.$sign->{'name'}.'(} '. | ||||||
| 520 | join(",\n", map { | ||||||
| 521 | 0 | '\texttt{'.$_->[0].'} '.$self->_mkClassRef($_->[1]); | |||||
| 522 | 0 | } @{$sign->{'params'}}).'\texttt{\color{orange})}'. | |||||
| 523 | #join(', ', map { $_->[0] } @{$sign->{'params'}}).'):} '. | ||||||
| 524 | ': '.$self->_mkClassRef($sign->{'returns'})."\n"; | ||||||
| 525 | |||||||
| 526 | 0 | 0 | if (scalar @{$sign->{'params'}} > 0) { | ||||
| 0 | |||||||
| 527 | #$tex .= '\renewcommand{\arraystretch}{1.0}'."\n\n"; | ||||||
| 528 | #$tex .= '\begin{tabular}{lcl}'."\n\n"; | ||||||
| 529 | #$tex .= join(",\n", map { | ||||||
| 530 | # '\texttt{'.$_->[0].'} : '.$self->_mkClassRef($_->[1]); | ||||||
| 531 | #} @{$sign->{'params'}}); | ||||||
| 532 | #foreach my $param (@{$sign->{'params'}}) { | ||||||
| 533 | # $tex .= '\texttt{'.$param->[0].'} : '.$self->_mkClassRef($param->[1])."\n"; | ||||||
| 534 | # # $code | ||||||
| 535 | #} | ||||||
| 536 | #$tex .= '\end{tabular}'."\n\n"; | ||||||
| 537 | #$tex .= '\renewcommand{\arraystretch}{1.2}'."\n\n"; | ||||||
| 538 | 0 | $tex .= "\n\n"; | |||||
| 539 | } | ||||||
| 540 | # if ($methname =~ /^getAppWindow/) { | ||||||
| 541 | # use Data::Dumper; | ||||||
| 542 | # print Dumper($class->{'subs-doc'}); | ||||||
| 543 | # } | ||||||
| 544 | 0 | $tex .= _docToLaTeX($class->{'subs-doc'}->{$methname})."\n\n"; | |||||
| 545 | # $tex .= '\begin{Verbatim}[fontsize=\footnotesize]'."\n"; | ||||||
| 546 | # $tex .= $code."\n"; | ||||||
| 547 | # $tex .= '\end{Verbatim}'."\n"; | ||||||
| 548 | #$tex .= '\vspace{3mm}'."\n\n"; | ||||||
| 549 | } | ||||||
| 550 | 0 | $tex .= '\end{description*}'."\n\n"; | |||||
| 551 | #$tex .= '\setlength{\parskip}{6pt}'."\n"; | ||||||
| 552 | } | ||||||
| 553 | |||||||
| 554 | 0 | return $tex; | |||||
| 555 | } | ||||||
| 556 | |||||||
| 557 | sub _docToLaTeX | ||||||
| 558 | { | ||||||
| 559 | 0 | 0 | my ($doc) = @_; | ||||
| 560 | 0 | my %replacements = ( | |||||
| 561 | '{ae}' => '\"a', | ||||||
| 562 | '{oe}' => '\"o', | ||||||
| 563 | '{ue}' => '\"u', | ||||||
| 564 | '{Ae}' => '\"A', | ||||||
| 565 | '{Oe}' => '\"O', | ||||||
| 566 | '{Ue}' => '\"U', | ||||||
| 567 | '{AE}' => '\"A', | ||||||
| 568 | '{OE}' => '\"O', | ||||||
| 569 | '{UE}' => '\"U', | ||||||
| 570 | '{ss}' => '\ss{}', | ||||||
| 571 | ); | ||||||
| 572 | 0 | map { | |||||
| 573 | 0 | my $match = quotemeta $_; | |||||
| 574 | 0 | my $replace = $replacements{$_}; | |||||
| 575 | 0 | $doc =~ s/$match/$replace/g; | |||||
| 576 | 0 | $_; | |||||
| 577 | } | ||||||
| 578 | keys %replacements; | ||||||
| 579 | |||||||
| 580 | # special replacements | ||||||
| 581 | 0 | $doc =~ s/t\{([^\}]*)\}/\\texttt{$1}/g; # t{...} -> fixed width text | |||||
| 582 | 0 | $doc =~ s/i\{([^\}]*)\}/\\textit{$1}/g; # i{...} -> italic text | |||||
| 583 | 0 | $doc =~ s/b\{([^\}]*)\}/\\textbf{$1}/g; # b{...} -> bold text | |||||
| 584 | |||||||
| 585 | 0 | return $doc; | |||||
| 586 | } | ||||||
| 587 | |||||||
| 588 | sub _mkClassRef | ||||||
| 589 | { | ||||||
| 590 | 0 | 0 | my ($self, $classname) = @_; | ||||
| 591 | return | ||||||
| 592 | 0 | 0 | (exists $self->{'classes'}->{$classname} ? | ||||
| 593 | '\textit{'.$classname.'}$_{\ref{Class'.$classname.'}}$' : | ||||||
| 594 | '\textit{\color{gray}'.$classname.'}'); | ||||||
| 595 | } | ||||||
| 596 | } | ||||||
| 597 | |||||||
| 598 | #------------------------------------------------------------------------------- | ||||||
| 599 | sub toDot | ||||||
| 600 | #------------------------------------------------------------------------------- | ||||||
| 601 | { | ||||||
| 602 | 0 | 0 | 1 | my ($self, $autogen, $classnames) = @_; | |||
| 603 | 0 | 0 | $autogen = 0 unless defined $autogen; | ||||
| 604 | |||||||
| 605 | 0 | 0 | 0 | die "Error: cannot call toDot() method AFTER generate() method has been called\n" | |||
| 606 | if $autogen == 0 && $self->{'autogen'} == 1; | ||||||
| 607 | #$self->_autogen(); | ||||||
| 608 | |||||||
| 609 | 0 | my $dot = | |||||
| 610 | 'digraph {'."\n". | ||||||
| 611 | q{ | ||||||
| 612 | fontname="Bitstream Vera Sans" | ||||||
| 613 | fontsize=8 | ||||||
| 614 | overlap=scale | ||||||
| 615 | |||||||
| 616 | node [ | ||||||
| 617 | fontname="Bitstream Vera Sans" | ||||||
| 618 | fontsize=8 | ||||||
| 619 | shape="record" | ||||||
| 620 | ] | ||||||
| 621 | |||||||
| 622 | edge [ | ||||||
| 623 | fontname="Bitstream Vera Sans" | ||||||
| 624 | fontsize=8 | ||||||
| 625 | //weight=0.1 | ||||||
| 626 | ] | ||||||
| 627 | |||||||
| 628 | }; | ||||||
| 629 | |||||||
| 630 | # add class nodes | ||||||
| 631 | 0 | foreach my $classname (keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 632 | 0 | 0 | next if _skip_class($classname,$classnames); | ||||
| 633 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 634 | 0 | $dot .= | |||||
| 635 | ' '.$classname.' ['."\n". | ||||||
| 636 | ' label="{'. | ||||||
| 637 | $classname.'|'. | ||||||
| 638 | 0 | join('\l', map { '+ '.$_.' : '.$class->{'attr'}->{$_} } keys %{$class->{'attr'}}).'\l|'. | |||||
| 0 | |||||||
| 639 | 0 | join('\l', map { $_ } keys %{$class->{'subs'}}).'\l}"'."\n". | |||||
| 0 | |||||||
| 640 | " ]\n\n"; | ||||||
| 641 | } | ||||||
| 642 | |||||||
| 643 | # add class relationships | ||||||
| 644 | 0 | $dot .= 'edge [ arrowhead="empty" color="black" ]'."\n\n"; | |||||
| 645 | 0 | foreach my $classname (keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 646 | 0 | 0 | next if _skip_class($classname,$classnames); | ||||
| 647 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 648 | 0 | foreach my $parentclassname (@{$class->{'isa'}}) { | |||||
| 0 | |||||||
| 649 | 0 | 0 | next if _skip_class($parentclassname,$classnames); | ||||
| 650 | 0 | $dot .= ' '.$classname.' -> '.$parentclassname."\n"; | |||||
| 651 | } | ||||||
| 652 | } | ||||||
| 653 | |||||||
| 654 | # add "contains" relationships | ||||||
| 655 | 0 | $dot .= 'edge [ arrowhead="vee" color="gray" ]'."\n\n"; | |||||
| 656 | 0 | foreach my $classname (keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 657 | 0 | 0 | next if _skip_class($classname,$classnames); | ||||
| 658 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 659 | 0 | foreach my $attrname (keys %{$class->{'attr'}}) { | |||||
| 0 | |||||||
| 660 | 0 | my $attrtype = $class->{'attr'}->{$attrname}; | |||||
| 661 | 0 | 0 | 0 | $dot .= ' '.$classname.' -> '.$attrtype."\n" | |||
| 662 | if exists $self->{'classes'}->{$attrtype} && | ||||||
| 663 | !_skip_class($attrtype,$classnames); | ||||||
| 664 | } | ||||||
| 665 | } | ||||||
| 666 | |||||||
| 667 | 0 | return $dot.'}'."\n"; | |||||
| 668 | } | ||||||
| 669 | |||||||
| 670 | #------------------------------------------------------------------------------- | ||||||
| 671 | sub toHtml | ||||||
| 672 | #------------------------------------------------------------------------------- | ||||||
| 673 | { | ||||||
| 674 | 0 | 0 | 1 | my ($self) = @_; | |||
| 675 | 0 | my $html = ''; | |||||
| 676 | |||||||
| 677 | 0 | $self->_autogen(); | |||||
| 678 | |||||||
| 679 | # oben: dropdown mit klassen-namen -> onclick wird klasse unten angezeigt | ||||||
| 680 | # unten: Beschreibung der aktuell ausgewaehlten klasse: isa, attr, subs | ||||||
| 681 | # (auch geerbte!) | ||||||
| 682 | |||||||
| 683 | 0 | my @classnames = sort keys %{$self->{'classes'}}; | |||||
| 0 | |||||||
| 684 | |||||||
| 685 | return | ||||||
| 686 | 0 | ''. | |||||
| 687 | ''. | ||||||
| 688 | ' |
||||||
| 689 | ''. | ||||||
| 813 | ''. | ||||||
| 820 | ''. | ||||||
| 821 | ''. | ||||||
| 822 | ' '. |
||||||
| 823 | 'Class: '. | ||||||
| 824 | ' | ||||||
| 825 | join('', map { | ||||||
| 826 | 0 | '' | |||||
| 827 | } @classnames). | ||||||
| 828 | ''. | ||||||
| 829 | ''. | ||||||
| 830 | ' '. |
||||||
| 831 | $self->_mkClassTree(). | ||||||
| 832 | ' generated by Code::Class::C '. |
||||||
| 833 | ''. | ||||||
| 834 | ''. | ||||||
| 835 | join('', map { | ||||||
| 836 | 0 | '' | |||||
| 837 | } @classnames). | ||||||
| 838 | ''. | ||||||
| 839 | ''; | ||||||
| 840 | |||||||
| 841 | sub _mkClassTree | ||||||
| 842 | { | ||||||
| 843 | 0 | 0 | my ($self) = @_; | ||||
| 844 | # find top classes (those without any parent classes) | ||||||
| 845 | 0 | my @topclasses = (); | |||||
| 846 | 0 | foreach my $classname (sort keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 847 | 0 | push @topclasses, $classname | |||||
| 848 | 0 | 0 | unless scalar @{$self->{'classes'}->{$classname}->{'isa'}}; | ||||
| 849 | } | ||||||
| 850 | |||||||
| 851 | 0 | my $html = '
|
|||||
| 852 | 0 | foreach my $classname (@topclasses) { | |||||
| 853 | 0 | $html .= | |||||
| 854 | ' |
||||||
| 855 | $self->_mkClassLink($classname).' '. | ||||||
| 856 | $self->_mkSubclassList($classname). | ||||||
| 857 | ''; | ||||||
| 858 | } | ||||||
| 859 | 0 | return $html.''; | |||||
| 860 | } | ||||||
| 861 | |||||||
| 862 | sub _mkSubclassList | ||||||
| 863 | { | ||||||
| 864 | 0 | 0 | my ($self, $classname) = @_; | ||||
| 865 | # find direct children | ||||||
| 866 | 0 | my @children = (); | |||||
| 867 | 0 | foreach my $cname (sort keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 868 | 0 | foreach my $parentclassname (sort @{$self->{'classes'}->{$cname}->{'isa'}}) { | |||||
| 0 | |||||||
| 869 | 0 | 0 | push @children, $cname | ||||
| 870 | if $classname eq $parentclassname; | ||||||
| 871 | } | ||||||
| 872 | } | ||||||
| 873 | return | ||||||
| 874 | 0 | (scalar @children ? | |||||
| 875 | '
|
||||||
| 876 | 0 | 0 | join('', map { ' |
||||
| 877 | '' | ||||||
| 878 | : ''); | ||||||
| 879 | } | ||||||
| 880 | |||||||
| 881 | sub _classToHtml | ||||||
| 882 | { | ||||||
| 883 | 0 | 0 | my ($self, $classname) = @_; | ||||
| 884 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 885 | 0 | my $html = ''.$classname.''; |
|||||
| 886 | |||||||
| 887 | 0 | $html .= 'Parent classes
|
|||||
| 888 | 0 | $html .= | |||||
| 889 | 0 | join(', ', map { $self->_mkClassLink($_) } | |||||
| 890 | 0 | sort @{$class->{'isa'}}); | |||||
| 891 | 0 | $html .= ''; | |||||
| 892 | 0 | 0 | $html .= ' none ' unless scalar @{$class->{'isa'}}; |
||||
| 0 | |||||||
| 893 | |||||||
| 894 | 0 | $html .= 'Child classes
|
|||||
| 895 | 0 | my $subclasses = $self->_get_subclasses(); | |||||
| 896 | 0 | $html .= | |||||
| 897 | 0 | join(', ', map { $self->_mkClassLink($_) } | |||||
| 898 | 0 | sort keys %{$subclasses->{$classname}}); | |||||
| 899 | 0 | $html .= ''; | |||||
| 900 | 0 | 0 | $html .= ' none ' unless scalar keys %{$subclasses->{$classname}}; |
||||
| 0 | |||||||
| 901 | |||||||
| 902 | 0 | $html .= 'Attributes
|
|||||
| 903 | 0 | foreach my $attrname (sort keys %{$class->{'attr'}}) { | |||||
| 0 | |||||||
| 904 | 0 | $html .= ' |
|||||
| 905 | } | ||||||
| 906 | 0 | $html .= ''; | |||||
| 907 | 0 | 0 | $html .= ' none ' unless scalar keys %{$class->{'attr'}}; |
||||
| 0 | |||||||
| 908 | |||||||
| 909 | 0 | $html .= 'Methods'; |
|||||
| 910 | 0 | my $meths = ''; | |||||
| 911 | 0 | foreach my $methname (sort keys %{$class->{'subs'}}) { | |||||
| 0 | |||||||
| 912 | 0 | my $sign = $self->_parse_signature($methname); | |||||
| 913 | 0 | my $code = $class->{'subs'}->{$methname}; | |||||
| 914 | 0 | $code =~ s/\t/ /g; | |||||
| 915 | 0 | $code =~ s/(\r?\n)\s\s/$1/g; | |||||
| 916 | 0 | $html .= ''.$sign->{'name'}.' '; | |||||
| 917 | 0 | $meths .= | |||||
| 918 | ' |
||||||
| 919 | ''. | ||||||
| 920 | $self->_mkClassLink($sign->{'returns'}).' : '. | ||||||
| 921 | ''.$sign->{'name'}.''. | ||||||
| 922 | 0 | ' ( '.join(', ', map { $self->_mkClassLink($_->[1]).' '.$_->[0] } @{$sign->{'params'}}).' )'. | |||||
| 0 | |||||||
| 923 | ''.$self->_highlightC($code).' |
||||||
| 924 | } | ||||||
| 925 | 0 | $html .= '
|
|||||
| 926 | 0 | 0 | $html .= ' none ' unless scalar keys %{$class->{'subs'}}; |
||||
| 0 | |||||||
| 927 | |||||||
| 928 | 0 | return $html; | |||||
| 929 | } | ||||||
| 930 | |||||||
| 931 | sub _highlightC | ||||||
| 932 | { | ||||||
| 933 | 0 | 0 | my ($self, $c) = @_; | ||||
| 934 | 0 | $c =~ s/(\"[^\"]*\")/$1<\/span>/g; | |||||
| 935 | 0 | $c =~ s/(if|else|for|return|self|while|void|static)/$1<\/span>/g; | |||||
| 936 | 0 | $c =~ s/(\/\/[^\n]*)/$1<\/span>/g; | |||||
| 937 | 0 | $c =~ s/(\/\*[^\*]*\*\/)/$1<\/span>/mg; | |||||
| 938 | 0 | $c =~ s/([a-zA-Z\_][a-zA-Z0-9\_]*)\(/$1<\/span>\(/g; | |||||
| 939 | 0 | return $c; | |||||
| 940 | } | ||||||
| 941 | |||||||
| 942 | sub _mkClassLink | ||||||
| 943 | { | ||||||
| 944 | 0 | 0 | my ($self, $classname) = @_; | ||||
| 945 | return | ||||||
| 946 | 0 | 0 | (exists $self->{'classes'}->{$classname} ? | ||||
| 947 | ''. | ||||||
| 948 | $classname. | ||||||
| 949 | '' | ||||||
| 950 | : ''.$classname.''); | ||||||
| 951 | } | ||||||
| 952 | } | ||||||
| 953 | |||||||
| 954 | #------------------------------------------------------------------------------- | ||||||
| 955 | sub generate | ||||||
| 956 | #------------------------------------------------------------------------------- | ||||||
| 957 | { | ||||||
| 958 | 0 | 0 | 1 | my ($self, %opts) = @_; | |||
| 959 | |||||||
| 960 | 0 | 0 | my $file = $opts{'file'} || die "Error: generate() needs a filename.\n"; | ||||
| 961 | 0 | 0 | my $lheaders = $opts{'localheaders'} || []; | ||||
| 962 | 0 | 0 | push @{$lheaders}, @{$opts{'headers'} || []}; | ||||
| 0 | |||||||
| 0 | |||||||
| 963 | 0 | 0 | my $gheaders = $opts{'globalheaders'} || []; | ||||
| 964 | 0 | 0 | my $maincode = $self->_load_code_from_file($opts{'main'} || ''); | ||||
| 965 | 0 | 0 | my $debug = $opts{'debug'} || 0; | ||||
| 966 | |||||||
| 967 | 0 | 0 | my $topcode = | ||||
| 968 | $self->_load_code_from_file($opts{'top'} || '')."\n\n". | ||||||
| 969 | $self->_load_code_from_file($self->{'area'}->{'top'}); | ||||||
| 970 | |||||||
| 971 | 0 | 0 | my $bottomcode = | ||||
| 972 | $self->_load_code_from_file($opts{'bottom'} || '')."\n\n". | ||||||
| 973 | $self->_load_code_from_file($self->{'area'}->{'bottom'}); | ||||||
| 974 | |||||||
| 975 | 0 | 0 | my $typescode = | ||||
| 976 | $self->_load_code_from_file($opts{'types'} || '')."\n\n". | ||||||
| 977 | $self->_load_code_from_file($self->{'area'}->{'types'}); | ||||||
| 978 | |||||||
| 979 | 0 | $self->_autogen(); | |||||
| 980 | |||||||
| 981 | # add standard headers needed | ||||||
| 982 | 0 | foreach my $h (qw(string stdio stdlib stdarg)) { | |||||
| 983 | 0 | unshift @{$gheaders}, $h | |||||
| 0 | |||||||
| 984 | 0 | 0 | unless scalar grep { $_ eq $h } @{$gheaders}; | ||||
| 0 | |||||||
| 985 | } | ||||||
| 986 | |||||||
| 987 | ############################################################################## | ||||||
| 988 | 0 | my $ccode = ''; | |||||
| 989 | |||||||
| 990 | # write headers | ||||||
| 991 | 0 | $ccode .= join '', map { '#include <'.$_.'.h>'."\n" } @{$gheaders}; | |||||
| 0 | |||||||
| 0 | |||||||
| 992 | 0 | $ccode .= join '', map { '#include "'.$_.'.h"'."\n" } @{$lheaders}; | |||||
| 0 | |||||||
| 0 | |||||||
| 993 | |||||||
| 994 | 0 | 0 | $ccode .= '#define CREATE_STACK_TRACE ('.($debug ? 1 : 0).')'."\n"; | ||||
| 995 | 0 | $ccode .= q{ | |||||
| 996 | /*----------------------------------------------------------------------------*/ | ||||||
| 997 | |||||||
| 998 | #if CREATE_STACK_TRACE | ||||||
| 999 | |||||||
| 1000 | #define STACKTRACE_MAX_LENGTH (10) | ||||||
| 1001 | char StackTrace[STACKTRACE_MAX_LENGTH][255]; | ||||||
| 1002 | int StackTraceLength = 0; | ||||||
| 1003 | |||||||
| 1004 | void printStackTrace (void) | ||||||
| 1005 | { | ||||||
| 1006 | int i; | ||||||
| 1007 | printf("Stack trace (last one last):\n"); | ||||||
| 1008 | for (i = 0; i < StackTraceLength; i++) { | ||||||
| 1009 | printf(" %d. %s()\n", i, StackTrace[i]); | ||||||
| 1010 | } | ||||||
| 1011 | } | ||||||
| 1012 | |||||||
| 1013 | void logStackTraceEntry (char* msg) | ||||||
| 1014 | { | ||||||
| 1015 | if (StackTraceLength < STACKTRACE_MAX_LENGTH) { | ||||||
| 1016 | sprintf(StackTrace[StackTraceLength], "%s", msg); | ||||||
| 1017 | StackTraceLength++; | ||||||
| 1018 | } | ||||||
| 1019 | else { | ||||||
| 1020 | /* move all entries one down */ | ||||||
| 1021 | int i; | ||||||
| 1022 | for (i = 1; i < StackTraceLength; i++) { | ||||||
| 1023 | sprintf(StackTrace[i-1], "%s", StackTrace[i]); | ||||||
| 1024 | } | ||||||
| 1025 | /* set last one */ | ||||||
| 1026 | sprintf(StackTrace[StackTraceLength-1], "%s", msg); | ||||||
| 1027 | } | ||||||
| 1028 | } | ||||||
| 1029 | |||||||
| 1030 | #endif | ||||||
| 1031 | |||||||
| 1032 | /*----------------------------------------------------------------------------*/ | ||||||
| 1033 | |||||||
| 1034 | typedef struct S_Object* Object; | ||||||
| 1035 | |||||||
| 1036 | struct S_Object { | ||||||
| 1037 | int classid; | ||||||
| 1038 | char classname[256]; | ||||||
| 1039 | void* data; | ||||||
| 1040 | }; | ||||||
| 1041 | |||||||
| 1042 | typedef Object my; | ||||||
| 1043 | |||||||
| 1044 | /*----------------------------------------------------------------------------*/ | ||||||
| 1045 | /* String functions */ | ||||||
| 1046 | |||||||
| 1047 | void setstr (char* dest, const char* src) { | ||||||
| 1048 | int i; | ||||||
| 1049 | for (i = 0; i < 256; i++) { | ||||||
| 1050 | dest[i] = src[i]; | ||||||
| 1051 | } | ||||||
| 1052 | } | ||||||
| 1053 | |||||||
| 1054 | int streq (char* s1, char* s2) { | ||||||
| 1055 | return (strcmp(s1, s2) == 0); | ||||||
| 1056 | } | ||||||
| 1057 | |||||||
| 1058 | }; | ||||||
| 1059 | |||||||
| 1060 | ############################################################################## | ||||||
| 1061 | # create hash of subclasses for each class | ||||||
| 1062 | 0 | my %subclasses = %{$self->_get_subclasses()}; | |||||
| 0 | |||||||
| 1063 | 0 | $ccode .= "/*-----------------------------------------------------------*/\n"; | |||||
| 1064 | 0 | $ccode .= "/* ISA Function */\n\n"; | |||||
| 1065 | 0 | $ccode .= 'int isa (int childid, int classid) {'."\n"; | |||||
| 1066 | 0 | $ccode .= ' if (childid == classid) { return 1; }'."\n"; | |||||
| 1067 | 0 | my $first = 1; | |||||
| 1068 | 0 | foreach my $classname (keys %subclasses) { | |||||
| 1069 | 0 | 0 | next unless scalar keys %{$subclasses{$classname}}; | ||||
| 0 | |||||||
| 1070 | 0 | my $classid = $self->{'classes'}->{$classname}->{'id'}; | |||||
| 1071 | 0 | my @clauses = (); | |||||
| 1072 | 0 | foreach my $childclassname (keys %{$subclasses{$classname}}) { | |||||
| 0 | |||||||
| 1073 | 0 | my $childclassid = $self->{'classes'}->{$childclassname}->{'id'}; | |||||
| 1074 | 0 | push @clauses, 'childid == '.$childclassid.'/*'.$childclassname.'*/'; | |||||
| 1075 | } | ||||||
| 1076 | $ccode .= | ||||||
| 1077 | 0 | 0 | ' '.($first ? 'if' : 'else if').' (classid == '.$classid.'/*'.$classname.'*/'. | ||||
| 0 | |||||||
| 1078 | (scalar @clauses ? ' && ('.join(' || ',@clauses).')' : '').') {'."\n". | ||||||
| 1079 | ' return 1;'."\n". | ||||||
| 1080 | ' }'."\n"; | ||||||
| 1081 | 0 | $first = 0; | |||||
| 1082 | } | ||||||
| 1083 | 0 | $ccode .= ' return 0;'."\n"; | |||||
| 1084 | 0 | $ccode .= '}'."\n\n"; | |||||
| 1085 | |||||||
| 1086 | ############################################################################## | ||||||
| 1087 | 0 | $ccode .= 'int classname2classid (char* classname) {'."\n"; | |||||
| 1088 | 0 | $first = 1; | |||||
| 1089 | 0 | foreach my $classname (keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 1090 | 0 | my $classid = $self->{'classes'}->{$classname}->{'id'}; | |||||
| 1091 | 0 | 0 | $ccode .= | ||||
| 1092 | ' '.($first ? 'if' : 'else if').' (streq(classname, "'.$classname.'")) {'."\n". | ||||||
| 1093 | ' return '.$classid.';'."\n". | ||||||
| 1094 | ' }'."\n"; | ||||||
| 1095 | 0 | $first = 0; | |||||
| 1096 | } | ||||||
| 1097 | 0 | $ccode .= ' return -1;'."\n"; | |||||
| 1098 | 0 | $ccode .= '}'."\n\n"; | |||||
| 1099 | |||||||
| 1100 | ############################################################################## | ||||||
| 1101 | 0 | $ccode .= "/*-----------------------------------------------------------*/\n"; | |||||
| 1102 | 0 | $ccode .= "/* Types */\n\n"; | |||||
| 1103 | 0 | my $typedefs = ''; | |||||
| 1104 | 0 | my $structs = ''; | |||||
| 1105 | 0 | foreach my $classname (keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 1106 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 1107 | |||||||
| 1108 | # typedef for class-specific struct pointer (member 'data' in S_Object struct) | ||||||
| 1109 | 0 | $typedefs .= 'typedef struct S_'.$self->_get_c_typename($classname).'* '.$self->_get_c_typename($classname).';'."\n\n"; | |||||
| 1110 | |||||||
| 1111 | # struct for the class | ||||||
| 1112 | 0 | $structs .= 'struct S_'.$self->_get_c_typename($classname).' {'."\n"; | |||||
| 1113 | 0 | 0 | $structs .= ' int dummy'.";\n" unless scalar keys %{$class->{'attr'}}; | ||||
| 0 | |||||||
| 1114 | 0 | foreach my $attrname (sort keys %{$class->{'attr'}}) { | |||||
| 0 | |||||||
| 1115 | 0 | my $attrtype = $class->{'attr'}->{$attrname}; | |||||
| 1116 | 0 | $structs .= ' '.$self->_get_c_attrtype($attrtype).' CCC_'.$attrname.";\n"; | |||||
| 1117 | } | ||||||
| 1118 | 0 | $structs .= "};\n\n"; | |||||
| 1119 | } | ||||||
| 1120 | 0 | $ccode .= $typedefs; | |||||
| 1121 | 0 | $ccode .= $typescode; | |||||
| 1122 | 0 | $ccode .= $structs; | |||||
| 1123 | |||||||
| 1124 | ############################################################################## | ||||||
| 1125 | 0 | $ccode .= "/*-----------------------------------------------------------*/\n"; | |||||
| 1126 | 0 | $ccode .= "/* User top code */\n\n"; | |||||
| 1127 | 0 | $ccode .= $topcode."\n\n"; | |||||
| 1128 | |||||||
| 1129 | ############################################################################## | ||||||
| 1130 | 0 | $ccode .= $self->_generate_functions()."\n\n"; | |||||
| 1131 | |||||||
| 1132 | ############################################################################## | ||||||
| 1133 | 0 | $ccode .= "/*-----------------------------------------------------------*/\n"; | |||||
| 1134 | 0 | $ccode .= "/* User bottom code */\n\n"; | |||||
| 1135 | 0 | $ccode .= $bottomcode."\n\n"; | |||||
| 1136 | |||||||
| 1137 | ############################################################################## | ||||||
| 1138 | 0 | 0 | if (length $maincode) { | ||||
| 1139 | 0 | $ccode .= "/*-----------------------------------------------------------*/\n"; | |||||
| 1140 | 0 | $ccode .= "/* Main function */\n\n"; | |||||
| 1141 | 0 | $ccode .= 'int main (int argc, char** argv) {'."\n"; | |||||
| 1142 | 0 | $ccode .= ' '.$maincode; | |||||
| 1143 | 0 | $ccode .= "\n}\n"; | |||||
| 1144 | } | ||||||
| 1145 | |||||||
| 1146 | 0 | 0 | open OUTFILE, '>'.$file | ||||
| 1147 | or die "Error: failed to open output file '$file': $!\n"; | ||||||
| 1148 | 0 | print OUTFILE $ccode; | |||||
| 1149 | 0 | close OUTFILE; | |||||
| 1150 | } | ||||||
| 1151 | |||||||
| 1152 | ################################################################################ | ||||||
| 1153 | ################################################################################ | ||||||
| 1154 | ################################################################################ | ||||||
| 1155 | |||||||
| 1156 | #------------------------------------------------------------------------------- | ||||||
| 1157 | sub _parse_signature | ||||||
| 1158 | #------------------------------------------------------------------------------- | ||||||
| 1159 | { | ||||||
| 1160 | 0 | 0 | my ($self, $signature_string) = @_; | ||||
| 1161 | |||||||
| 1162 | # render(self:Square,self:Vertex,self:Point):void | ||||||
| 1163 | 0 | my $rs = '[\s\t\n\r]*'; | |||||
| 1164 | 0 | my $rn = '[^\(\)\,\:]+'; | |||||
| 1165 | 0 | my ($name, $args, $returns) = ($signature_string =~ /^$rs($rn)$rs\($rs(.*)$rs\)$rs\:$rs($rn)$rs$/); | |||||
| 1166 | 0 | my @params = map { [split /$rs\:$rs/] } split /$rs\,$rs/, $args; | |||||
| 0 | |||||||
| 1167 | |||||||
| 1168 | 0 | my $sign = { | |||||
| 1169 | name => $name, | ||||||
| 1170 | returns => $returns, | ||||||
| 1171 | params => \@params, | ||||||
| 1172 | }; | ||||||
| 1173 | 0 | return $sign; | |||||
| 1174 | } | ||||||
| 1175 | |||||||
| 1176 | #------------------------------------------------------------------------------- | ||||||
| 1177 | sub _dbg | ||||||
| 1178 | #------------------------------------------------------------------------------- | ||||||
| 1179 | { | ||||||
| 1180 | 0 | 0 | my (@msg) = @_; | ||||
| 1181 | 0 | eval('use Data::Dump;'); | |||||
| 1182 | 0 | Data::Dump::dump(\@msg); | |||||
| 1183 | } | ||||||
| 1184 | |||||||
| 1185 | #------------------------------------------------------------------------------- | ||||||
| 1186 | sub _get_subclasses | ||||||
| 1187 | #------------------------------------------------------------------------------- | ||||||
| 1188 | { | ||||||
| 1189 | 0 | 0 | my ($self) = @_; | ||||
| 1190 | 0 | my %subclasses = (); | |||||
| 1191 | 0 | foreach my $classname (keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 1192 | 0 | my $classid = $self->{'classes'}->{$classname}->{'id'}; | |||||
| 1193 | 0 | 0 | $subclasses{$classname} = {} unless exists $subclasses{$classname}; | ||||
| 1194 | #$subclasses{$classname}->{$classname} = 1; | ||||||
| 1195 | 0 | foreach my $parentclassname ($self->_get_parent_classes($classname)) { | |||||
| 1196 | 0 | my $parentclassid = $self->{'classes'}->{$parentclassname}->{'id'}; | |||||
| 1197 | 0 | $subclasses{$parentclassname}->{$classname} = 1; | |||||
| 1198 | } | ||||||
| 1199 | } | ||||||
| 1200 | 0 | return \%subclasses; | |||||
| 1201 | } | ||||||
| 1202 | |||||||
| 1203 | #------------------------------------------------------------------------------- | ||||||
| 1204 | sub _autogen | ||||||
| 1205 | #------------------------------------------------------------------------------- | ||||||
| 1206 | { | ||||||
| 1207 | 0 | 0 | my ($self) = @_; | ||||
| 1208 | 0 | 0 | unless ($self->{'autogen'}) { | ||||
| 1209 | 0 | $self->_inherit_members(); | |||||
| 1210 | |||||||
| 1211 | 0 | $self->_define_accessors(); | |||||
| 1212 | 0 | $self->_add_hook_code(); | |||||
| 1213 | 0 | $self->_define_constructors(); | |||||
| 1214 | 0 | $self->_define_destructors(); | |||||
| 1215 | 0 | $self->_define_dumpers(); | |||||
| 1216 | 0 | $self->{'autogen'} = 1; | |||||
| 1217 | } | ||||||
| 1218 | } | ||||||
| 1219 | |||||||
| 1220 | #------------------------------------------------------------------------------- | ||||||
| 1221 | sub _generate_functions | ||||||
| 1222 | #------------------------------------------------------------------------------- | ||||||
| 1223 | { | ||||||
| 1224 | 0 | 0 | my ($self) = @_; | ||||
| 1225 | |||||||
| 1226 | # find all functions and store them by their name | ||||||
| 1227 | 0 | my %functions = (); # " |
|||||
| 1228 | 0 | foreach my $classname (keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 1229 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 1230 | 0 | foreach my $name (keys %{$class->{'subs'}}) { | |||||
| 0 | |||||||
| 1231 | 0 | my $sign = $self->_parse_signature($name); | |||||
| 1232 | 0 | 0 | $functions{$sign->{'name'}} = {} | ||||
| 1233 | unless exists $functions{$sign->{'name'}}; | ||||||
| 1234 | |||||||
| 1235 | 0 | $functions{$sign->{'name'}}->{$name} = | |||||
| 1236 | { | ||||||
| 1237 | 'classname' => $classname, | ||||||
| 1238 | 'number' => undef, | ||||||
| 1239 | 'name' => $name, | ||||||
| 1240 | 'code' => $self->{'classes'}->{$classname}->{'subs'}->{$name}, | ||||||
| 1241 | }; | ||||||
| 1242 | } | ||||||
| 1243 | } | ||||||
| 1244 | # add normal functions, too | ||||||
| 1245 | 0 | foreach my $fname (keys %{$self->{'functions'}}) { | |||||
| 0 | |||||||
| 1246 | 0 | my $sign = $self->_parse_signature($fname); | |||||
| 1247 | 0 | $functions{$sign->{'name'}}->{$fname} = | |||||
| 1248 | { | ||||||
| 1249 | 'classname' => undef, | ||||||
| 1250 | 'number' => undef, | ||||||
| 1251 | 'name' => $fname, | ||||||
| 1252 | 'code' => $self->{'functions'}->{$fname}, | ||||||
| 1253 | }; | ||||||
| 1254 | } | ||||||
| 1255 | # give every implementation a unique number | ||||||
| 1256 | 0 | foreach my $fname (keys %functions) { | |||||
| 1257 | 0 | my $n = 0; | |||||
| 1258 | 0 | foreach my $name (keys %{$functions{$fname}}) { | |||||
| 0 | |||||||
| 1259 | 0 | $functions{$fname}->{$name}->{'number'} = $n; | |||||
| 1260 | 0 | $n++; | |||||
| 1261 | } | ||||||
| 1262 | } | ||||||
| 1263 | |||||||
| 1264 | ###### | ||||||
| 1265 | |||||||
| 1266 | # check all overloaded functions: they are only allowed if they | ||||||
| 1267 | # take class-typed parameters ONLY! | ||||||
| 1268 | 0 | my %infos = (); # |
|||||
| 1269 | 0 | foreach my $fname (keys %functions) { | |||||
| 1270 | #print "($fname)\n"; | ||||||
| 1271 | |||||||
| 1272 | # define scheme of signature | ||||||
| 1273 | 0 | my $first_sign = $self->_parse_signature((keys %{$functions{$fname}})[0]); | |||||
| 0 | |||||||
| 1274 | |||||||
| 1275 | 0 | 0 | my $returns = | ||||
| 1276 | (exists $self->{'classes'}->{$first_sign->{'returns'}} ? | ||||||
| 1277 | 'Object' : $first_sign->{'returns'}); | ||||||
| 1278 | |||||||
| 1279 | 0 | my $all_class_types = | |||||
| 1280 | 0 | (scalar(grep { exists $self->{'classes'}->{$_} } @{$first_sign->{'params'}}) | |||||
| 0 | |||||||
| 1281 | 0 | 0 | == scalar(@{$first_sign->{'params'}}) ? 1 : 0); | ||||
| 1282 | |||||||
| 1283 | 0 | 0 | my $params = [ # sequence of "Object" or " |
||||
| 1284 | 0 | map { exists $self->{'classes'}->{$_->[1]} ? 'Object' : $_->[1] } | |||||
| 1285 | 0 | @{$first_sign->{'params'}} | |||||
| 1286 | ]; | ||||||
| 1287 | |||||||
| 1288 | 0 | $infos{$fname} = { | |||||
| 1289 | 'all-class-types' => $all_class_types, | ||||||
| 1290 | 'params-scheme' => $params, | ||||||
| 1291 | 'returns' => $returns, | ||||||
| 1292 | 'at-least-one-impl-has-zero-params' => 0, | ||||||
| 1293 | 0 | 'has-only-one-implementation' => (scalar(keys %{$functions{$fname}}) == 1), | |||||
| 1294 | }; | ||||||
| 1295 | |||||||
| 1296 | 0 | 0 | if (scalar keys %{$functions{$fname}} > 2) { | ||||
| 0 | |||||||
| 1297 | |||||||
| 1298 | # check if all signatures match the scheme | ||||||
| 1299 | 0 | foreach my $name (keys %{$functions{$fname}}) { | |||||
| 0 | |||||||
| 1300 | #print " [$name]\n"; | ||||||
| 1301 | 0 | my $sign = $self->_parse_signature($name); | |||||
| 1302 | 0 | 0 | $sign->{'returns'} = | ||||
| 1303 | (exists $self->{'classes'}->{$sign->{'returns'}} ? | ||||||
| 1304 | 'Object' : $sign->{'returns'}); | ||||||
| 1305 | |||||||
| 1306 | 0 | 0 | die "Error: overloaded method '$name' does not return a valid ". | ||||
| 1307 | "return type (is '$sign->{'returns'}', must be '$returns')\n" | ||||||
| 1308 | if $returns ne $sign->{'returns'}; | ||||||
| 1309 | |||||||
| 1310 | 0 | $infos{$name}->{'at-least-one-impl-has-zero-params'} = 1 | |||||
| 1311 | 0 | 0 | if scalar @{$sign->{'params'}} == 0; | ||||
| 1312 | |||||||
| 1313 | 0 | 0 | if ($all_class_types) { | ||||
| 1314 | # all parameters should be class-typed | ||||||
| 1315 | 0 | 0 | map { | ||||
| 1316 | 0 | die "Error: overloaded method '$name' is not allowed to take ". | |||||
| 1317 | "non-class typed parameters\n" | ||||||
| 1318 | if !exists $self->{'classes'}->{$_->[1]}; | ||||||
| 1319 | } | ||||||
| 1320 | 0 | @{$sign->{'params'}}; | |||||
| 1321 | } | ||||||
| 1322 | else { | ||||||
| 1323 | # the parameter list should match the $params list | ||||||
| 1324 | 0 | for (my $p = 0; $p < @{$params}; $p++) { | |||||
| 0 | |||||||
| 1325 | 0 | my $paramtype = $params->[$p]; | |||||
| 1326 | 0 | die "Error: overloaded method '$name' does not ". | |||||
| 1327 | 0 | "follow the scheme 'method(".join(',',@{$params})."):$returns'\n" | |||||
| 1328 | if | ||||||
| 1329 | 0 | 0 | 0 | ($p > scalar @{$sign->{'params'}} - 1) || | |||
| 0 | |||||||
| 0 | |||||||
| 0 | |||||||
| 1330 | ($paramtype eq 'Object' && | ||||||
| 1331 | !exists $self->{'classes'}->{$sign->{'params'}->[$p]->[1]}) || | ||||||
| 1332 | ($paramtype ne 'Object' && | ||||||
| 1333 | $paramtype ne $sign->{'params'}->[$p]->[1]); | ||||||
| 1334 | } | ||||||
| 1335 | } | ||||||
| 1336 | } | ||||||
| 1337 | } | ||||||
| 1338 | } | ||||||
| 1339 | |||||||
| 1340 | # generate c code | ||||||
| 1341 | 0 | my $protos = ''; # prototypes for implementation functions | |||||
| 1342 | 0 | my $impls = ''; # implementation functions | |||||
| 1343 | |||||||
| 1344 | 0 | foreach my $fname (sort keys %functions) { | |||||
| 1345 | 0 | my $info = $infos{$fname}; | |||||
| 1346 | |||||||
| 1347 | 0 | my $first_impl_name = (keys %{$functions{$fname}})[0]; | |||||
| 0 | |||||||
| 1348 | 0 | my $first_sign = $self->_parse_signature($first_impl_name); | |||||
| 1349 | |||||||
| 1350 | 0 | $protos .= | |||||
| 1351 | $info->{'returns'}.' '.$fname.' ('. | ||||||
| 1352 | $self->_generate_params_declaration($first_impl_name).');'."\n"; | ||||||
| 1353 | |||||||
| 1354 | 0 | $impls .= | |||||
| 1355 | $info->{'returns'}.' '.$fname.' ('. | ||||||
| 1356 | $self->_generate_params_declaration($first_impl_name).') {'."\n"; | ||||||
| 1357 | |||||||
| 1358 | 0 | my $first = 1; | |||||
| 1359 | 0 | for my $name (keys %{$functions{$fname}}) { | |||||
| 0 | |||||||
| 1360 | 0 | 0 | $impls .= | ||||
| 1361 | ' '.($first ? '' : 'else ').'if '. | ||||||
| 1362 | '('.$self->_generate_wrapper_select_clause($name).') {'."\n". | ||||||
| 1363 | ' #if CREATE_STACK_TRACE'."\n". | ||||||
| 1364 | ' logStackTraceEntry("'.$name.'");'."\n". | ||||||
| 1365 | ' #endif'."\n". | ||||||
| 1366 | ' {'."\n". | ||||||
| 1367 | ' '.$functions{$fname}->{$name}->{'code'}."\n". | ||||||
| 1368 | ' }'."\n". | ||||||
| 1369 | ' }'."\n"; | ||||||
| 1370 | 0 | $first = 0; | |||||
| 1371 | } | ||||||
| 1372 | |||||||
| 1373 | 0 | $impls .= ' else {'."\n"; | |||||
| 1374 | 0 | $impls .= ' printf("Error: Failed to find an implementation of function/method \''.$fname.'\'.\n");'."\n"; | |||||
| 1375 | 0 | $impls .= ' #if CREATE_STACK_TRACE'."\n"; | |||||
| 1376 | 0 | $impls .= ' printStackTrace();'."\n"; | |||||
| 1377 | 0 | $impls .= ' #endif'."\n"; | |||||
| 1378 | 0 | $impls .= ' printf("The parameters passed were:\n");'."\n"; | |||||
| 1379 | 0 | my $p = 0; | |||||
| 1380 | 0 | for my $param (@{$first_sign->{'params'}}) { | |||||
| 0 | |||||||
| 1381 | 0 | my $paramname = $param->[0]; | |||||
| 1382 | 0 | my $paramtype = $param->[1]; | |||||
| 1383 | 0 | 0 | if (exists $self->{'classes'}->{$paramtype}) { | ||||
| 1384 | 0 | $impls .= ' printf(" ['.$p.'] = %s\n", '.$paramname.'->classname);'."\n"; | |||||
| 1385 | } else { | ||||||
| 1386 | 0 | $impls .= ' printf(" ['.$p.'] = '.$paramtype.'\n");'."\n"; | |||||
| 1387 | } | ||||||
| 1388 | 0 | $p++; | |||||
| 1389 | } | ||||||
| 1390 | 0 | $impls .= ' exit(0);'."\n"; | |||||
| 1391 | 0 | $impls .= ' }'."\n"; | |||||
| 1392 | 0 | $impls .= '}'."\n\n"; | |||||
| 1393 | } | ||||||
| 1394 | |||||||
| 1395 | return | ||||||
| 1396 | 0 | "/*-----------------------------------------------------------*/\n". | |||||
| 1397 | "/* Prototypes for implementation functions */\n\n". | ||||||
| 1398 | $protos."\n". | ||||||
| 1399 | |||||||
| 1400 | "/*-----------------------------------------------------------*/\n". | ||||||
| 1401 | "/* Implementation functions */\n\n". | ||||||
| 1402 | $impls."\n"; | ||||||
| 1403 | } | ||||||
| 1404 | |||||||
| 1405 | #------------------------------------------------------------------------------- | ||||||
| 1406 | sub _generate_wrapper_select_clause | ||||||
| 1407 | #------------------------------------------------------------------------------- | ||||||
| 1408 | { | ||||||
| 1409 | 0 | 0 | my ($self, $implname, $use_isa) = @_; | ||||
| 1410 | 0 | my $sign = $self->_parse_signature($implname); | |||||
| 1411 | 0 | my @clauses = (); | |||||
| 1412 | 0 | my $p = 0; | |||||
| 1413 | 0 | foreach my $param (@{$sign->{'params'}}) { | |||||
| 0 | |||||||
| 1414 | 0 | my $paramname = $param->[0]; | |||||
| 1415 | 0 | my $paramtype = $param->[1]; | |||||
| 1416 | 0 | 0 | if (exists $self->{'classes'}->{$paramtype}) { | ||||
| 1417 | 0 | my $class = $self->{'classes'}->{$param->[1]}; | |||||
| 1418 | 0 | 0 | push @clauses, | ||||
| 1419 | ($p > 0 ? | ||||||
| 1420 | '('.$paramname.' == NULL || isa('.$paramname.'->classid, '.$class->{'id'}.'/* '.$paramtype.' */))' : | ||||||
| 1421 | $paramname.'->classid == '.$class->{'id'}.'/* '.$paramtype.' */'); | ||||||
| 1422 | } | ||||||
| 1423 | 0 | $p++; | |||||
| 1424 | } | ||||||
| 1425 | 0 | 0 | return (scalar @clauses ? join(' && ',@clauses) : '1'); | ||||
| 1426 | } | ||||||
| 1427 | |||||||
| 1428 | #------------------------------------------------------------------------------- | ||||||
| 1429 | sub _generate_params_declaration | ||||||
| 1430 | #------------------------------------------------------------------------------- | ||||||
| 1431 | { | ||||||
| 1432 | 0 | 0 | my ($self, $implname) = @_; | ||||
| 1433 | 0 | my $sign = $self->_parse_signature($implname); | |||||
| 1434 | 0 | my @params = (); | |||||
| 1435 | 0 | foreach my $param (@{$sign->{'params'}}) { | |||||
| 0 | |||||||
| 1436 | 0 | 0 | my $paramtype = | ||||
| 1437 | (exists $self->{'classes'}->{$param->[1]} ? 'Object' : $param->[1]); | ||||||
| 1438 | 0 | push @params, $paramtype.' '.$param->[0]; | |||||
| 1439 | } | ||||||
| 1440 | 0 | 0 | return (scalar @params ? join(', ', @params) : 'void'); | ||||
| 1441 | } | ||||||
| 1442 | |||||||
| 1443 | #------------------------------------------------------------------------------- | ||||||
| 1444 | sub _init | ||||||
| 1445 | #------------------------------------------------------------------------------- | ||||||
| 1446 | { | ||||||
| 1447 | 0 | 0 | my ($self, %opts) = @_; | ||||
| 1448 | |||||||
| 1449 | 0 | $self->{'classes'} = {}; | |||||
| 1450 | 0 | $self->{'functions'} = {}; | |||||
| 1451 | |||||||
| 1452 | # if attributes/methods etc. have been auto-generated | ||||||
| 1453 | 0 | $self->{'autogen'} = 0; | |||||
| 1454 | |||||||
| 1455 | # prefix for type names created by this module | ||||||
| 1456 | 0 | $self->{'prefix-types'} = 'T_'; | |||||
| 1457 | |||||||
| 1458 | # code areas that can be filled as classes are parsed/read | ||||||
| 1459 | 0 | $self->{'area'} = { | |||||
| 1460 | 'top' => '', | ||||||
| 1461 | 'bottom' => '', | ||||||
| 1462 | }; | ||||||
| 1463 | |||||||
| 1464 | 0 | return $self; | |||||
| 1465 | } | ||||||
| 1466 | |||||||
| 1467 | # inherits all members from parent classes | ||||||
| 1468 | #------------------------------------------------------------------------------- | ||||||
| 1469 | sub _inherit_members | ||||||
| 1470 | #------------------------------------------------------------------------------- | ||||||
| 1471 | { | ||||||
| 1472 | 0 | 0 | my ($self) = @_; | ||||
| 1473 | # copy all inherited members from the parent classes | ||||||
| 1474 | 0 | foreach my $classname (keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 1475 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 1476 | 0 | foreach my $parentclassname ($self->_get_parent_classes($classname)) { | |||||
| 1477 | 0 | my $parentclass = $self->{'classes'}->{$parentclassname}; | |||||
| 1478 | 0 | foreach my $membertype (qw(attr subs after before)) { | |||||
| 1479 | 0 | foreach my $membername (keys %{$parentclass->{$membertype}}) { | |||||
| 0 | |||||||
| 1480 | 0 | 0 | 0 | if ($membertype eq 'attr' && exists $class->{$membertype}->{$membername}) { | |||
| 1481 | 0 | 0 | die "Error: inherited attribute '$membername' in class $classname must be of the same type as in class '$parentclassname'\n" | ||||
| 1482 | if $class->{$membertype}->{$membername} ne $parentclass->{$membertype}->{$membername}; | ||||||
| 1483 | } | ||||||
| 1484 | |||||||
| 1485 | 0 | my $orig_membername = $membername; | |||||
| 1486 | 0 | 0 | if ($membertype eq 'subs') { | ||||
| 1487 | 0 | my $sign = $self->_parse_signature($membername); | |||||
| 1488 | 0 | $sign->{'params'}->[0]->[1] = $classname; | |||||
| 1489 | 0 | $membername = $self->_signature_to_string($sign); | |||||
| 1490 | } | ||||||
| 1491 | |||||||
| 1492 | 0 | 0 | unless (exists $class->{$membertype}->{$membername}) { | ||||
| 1493 | 0 | $class->{$membertype}->{$membername} = | |||||
| 1494 | $parentclass->{$membertype}->{$orig_membername}; | ||||||
| 1495 | } | ||||||
| 1496 | } | ||||||
| 1497 | } | ||||||
| 1498 | } | ||||||
| 1499 | } | ||||||
| 1500 | } | ||||||
| 1501 | |||||||
| 1502 | #------------------------------------------------------------------------------- | ||||||
| 1503 | sub _add_hook_code | ||||||
| 1504 | #------------------------------------------------------------------------------- | ||||||
| 1505 | { | ||||||
| 1506 | 0 | 0 | my ($self) = @_; | ||||
| 1507 | 0 | foreach my $hooktype (qw(before after)) { | |||||
| 1508 | 0 | foreach my $classname (keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 1509 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 1510 | 0 | foreach my $methname (keys %{$class->{$hooktype}}) { | |||||
| 0 | |||||||
| 1511 | 0 | 0 | 0 | next if $methname eq 'new' || $methname eq 'delete'; | |||
| 1512 | |||||||
| 1513 | 0 | my $methods = $self->_get_methods_by_name($class, $methname); | |||||
| 1514 | 0 | die "Error: $hooktype-hook for $classname.$methname cannot be installed, ". | |||||
| 1515 | "because no method with that name exists in $classname.\n" | ||||||
| 1516 | 0 | 0 | unless scalar keys %{$methods}; | ||||
| 1517 | |||||||
| 1518 | # add hook code | ||||||
| 1519 | 0 | foreach my $meth (keys %{$methods}) { | |||||
| 0 | |||||||
| 1520 | 0 | 0 | if ($hooktype eq 'before') { | ||||
| 0 | |||||||
| 1521 | 0 | $class->{'subs'}->{$meth} = | |||||
| 1522 | "{\n".$class->{$hooktype}->{$methname}."\n}\n".$class->{'subs'}->{$meth}; | ||||||
| 1523 | } | ||||||
| 1524 | elsif ($hooktype eq 'after') { | ||||||
| 1525 | 0 | $class->{'subs'}->{$meth} = | |||||
| 1526 | $class->{'subs'}->{$meth}."{\n".$class->{$hooktype}->{$methname}."\n}\n"; | ||||||
| 1527 | } | ||||||
| 1528 | } | ||||||
| 1529 | } | ||||||
| 1530 | } | ||||||
| 1531 | } | ||||||
| 1532 | } | ||||||
| 1533 | |||||||
| 1534 | # finds all methods in a class with the same name | ||||||
| 1535 | #------------------------------------------------------------------------------- | ||||||
| 1536 | sub _get_methods_by_name | ||||||
| 1537 | #------------------------------------------------------------------------------- | ||||||
| 1538 | { | ||||||
| 1539 | 0 | 0 | my ($self, $class, $methname) = @_; | ||||
| 1540 | 0 | my %subs = (); | |||||
| 1541 | 0 | foreach my $s (keys %{$class->{'subs'}}) { | |||||
| 0 | |||||||
| 1542 | 0 | my $sign = $self->_parse_signature($s); | |||||
| 1543 | 0 | 0 | $subs{$s} = $class->{'subs'}->{$s} | ||||
| 1544 | if $sign->{'name'} eq $methname; | ||||||
| 1545 | } | ||||||
| 1546 | 0 | return \%subs; | |||||
| 1547 | } | ||||||
| 1548 | |||||||
| 1549 | #------------------------------------------------------------------------------- | ||||||
| 1550 | sub _define_constructors | ||||||
| 1551 | #------------------------------------------------------------------------------- | ||||||
| 1552 | { | ||||||
| 1553 | 0 | 0 | my ($self) = @_; | ||||
| 1554 | 0 | foreach my $classname (keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 1555 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 1556 | |||||||
| 1557 | 0 | $self->func( | |||||
| 1558 | 'new_'.ucfirst($classname).'():Object', | ||||||
| 1559 | |||||||
| 1560 | 'Object self = NULL;'."\n". | ||||||
| 1561 | |||||||
| 1562 | # pre hook | ||||||
| 1563 | (exists $class->{'before'}->{'new'} ? | ||||||
| 1564 | "{\n".$class->{'before'}->{'new'}."\n}\n" : ''). | ||||||
| 1565 | |||||||
| 1566 | "{\n". | ||||||
| 1567 | ' self = (Object)malloc(sizeof(struct S_Object));'."\n". | ||||||
| 1568 | ' if (self == (Object)NULL) {'."\n". | ||||||
| 1569 | ' printf("Failed to allocate memory for instance of class \''.$classname.'\'\n");'."\n". | ||||||
| 1570 | ' exit(1);'."\n". | ||||||
| 1571 | ' }'."\n". | ||||||
| 1572 | ' self->classid = '.$class->{'id'}.';'."\n". | ||||||
| 1573 | ' setstr(self->classname, "'.$classname.'");'."\n". | ||||||
| 1574 | ' self->data = malloc(sizeof(struct S_'.$self->_get_c_typename($classname).'));'."\n". | ||||||
| 1575 | ' if (self->data == NULL) {'."\n". | ||||||
| 1576 | ' printf("Failed to allocate memory for instance-data of class \''.$classname.'\'\n");'."\n". | ||||||
| 1577 | ' exit(1);'."\n". | ||||||
| 1578 | ' }'."\n". | ||||||
| 1579 | join('', | ||||||
| 1580 | map { | ||||||
| 1581 | 0 | my $attrtype = $class->{'attr'}->{$_}; | |||||
| 1582 | 0 | 0 | ($attrtype eq 'pthread_mutex_t' ? | ||||
| 1583 | '' : | ||||||
| 1584 | ' (('.$self->_get_c_typename($classname).')(self->data))->CCC_'.$_. | ||||||
| 1585 | ' = '.$self->_get_init_c_code($attrtype).';'."\n"); | ||||||
| 1586 | } | ||||||
| 1587 | 0 | 0 | sort keys %{$class->{'attr'}} | ||||
| 0 | |||||||
| 1588 | ). | ||||||
| 1589 | "}\n". | ||||||
| 1590 | |||||||
| 1591 | # post hook | ||||||
| 1592 | (exists $class->{'after'}->{'new'} ? | ||||||
| 1593 | "{\n".$class->{'after'}->{'new'}."\n}\n" : ''). | ||||||
| 1594 | ' return self;'."\n" | ||||||
| 1595 | ); | ||||||
| 1596 | } | ||||||
| 1597 | } | ||||||
| 1598 | |||||||
| 1599 | #------------------------------------------------------------------------------- | ||||||
| 1600 | sub _define_dumpers | ||||||
| 1601 | #------------------------------------------------------------------------------- | ||||||
| 1602 | { | ||||||
| 1603 | 0 | 0 | my ($self) = @_; | ||||
| 1604 | 0 | foreach my $classname (keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 1605 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 1606 | |||||||
| 1607 | 0 | my $funcsign = 'dump(self:'.$classname.',level:int,maxLevel:int):void'; | |||||
| 1608 | 0 | 0 | next if exists $self->{'functions'}->{$funcsign}; | ||||
| 1609 | |||||||
| 1610 | 0 | $self->func( | |||||
| 1611 | $funcsign, | ||||||
| 1612 | |||||||
| 1613 | # pre hook | ||||||
| 1614 | (exists $class->{'before'}->{'dump'} ? | ||||||
| 1615 | "{\n".$class->{'before'}->{'dump'}."\n}\n" : ''). | ||||||
| 1616 | |||||||
| 1617 | "{\n". | ||||||
| 1618 | ' int i;'."\n". | ||||||
| 1619 | ' char indent[256];'."\n". | ||||||
| 1620 | ' indent[0] = \'\\0\';'."\n". | ||||||
| 1621 | ' for (i = 0; i < level; i += 1) {'."\n". | ||||||
| 1622 | ' strcat(indent, " ");'."\n". | ||||||
| 1623 | ' }'."\n". | ||||||
| 1624 | |||||||
| 1625 | 'if (level <= maxLevel && maxLevel <= 64) {'."\n". | ||||||
| 1626 | |||||||
| 1627 | ' if (self == NULL) {'."\n". | ||||||
| 1628 | ' printf("%s(NULL)\n", indent);'."\n". | ||||||
| 1629 | ' }'."\n". | ||||||
| 1630 | ' else {'."\n". | ||||||
| 1631 | |||||||
| 1632 | ' printf("%s{'.$classname.' #'.$class->{'id'}.'\n", indent);'."\n". | ||||||
| 1633 | join('', | ||||||
| 1634 | map { | ||||||
| 1635 | 0 | my $s = ' printf("%s .'.$_.' <'.$class->{'attr'}->{$_}.'> = ", indent);'."\n"; | |||||
| 1636 | 0 | 0 | if (exists $self->{'classes'}->{$class->{'attr'}->{$_}}) { | ||||
| 0 | |||||||
| 0 | |||||||
| 0 | |||||||
| 0 | |||||||
| 0 | |||||||
| 1637 | 0 | $s .= | |||||
| 1638 | ' printf("\n");'. | ||||||
| 1639 | ' if (get'.ucfirst($_).'(self) == NULL)'."\n". | ||||||
| 1640 | ' printf("%s (NULL)\n", indent);'."\n". | ||||||
| 1641 | ' else '."\n". | ||||||
| 1642 | ' dump(get'.ucfirst($_).'(self),level+1,maxLevel);'."\n"; | ||||||
| 1643 | } | ||||||
| 1644 | elsif ($class->{'attr'}->{$_} eq 'float') { | ||||||
| 1645 | 0 | $s .= ' printf("%f\n", get'.ucfirst($_).'(self));'."\n"; | |||||
| 1646 | } | ||||||
| 1647 | elsif ($class->{'attr'}->{$_} eq 'int') { | ||||||
| 1648 | 0 | $s .= ' printf("%d\n", get'.ucfirst($_).'(self));'."\n"; | |||||
| 1649 | } | ||||||
| 1650 | elsif ($class->{'attr'}->{$_} eq 'long int') { | ||||||
| 1651 | 0 | $s .= ' printf("%ld\n", get'.ucfirst($_).'(self));'."\n"; | |||||
| 1652 | } | ||||||
| 1653 | elsif ($class->{'attr'}->{$_} eq 'char') { | ||||||
| 1654 | 0 | $s .= ' printf("%d / \'%c\'\n", get'.ucfirst($_).'(self), get'.ucfirst($_).'(self));'."\n"; | |||||
| 1655 | } | ||||||
| 1656 | elsif ($class->{'attr'}->{$_} eq 'char*') { | ||||||
| 1657 | 0 | $s .= ' printf("\'%s\'\n", get'.ucfirst($_).'(self));'."\n"; | |||||
| 1658 | } | ||||||
| 1659 | else { | ||||||
| 1660 | 0 | $s .= ' printf("?\n");'."\n"; | |||||
| 1661 | } | ||||||
| 1662 | 0 | $s; | |||||
| 1663 | } | ||||||
| 1664 | 0 | 0 | sort keys %{$class->{'attr'}} | ||||
| 0 | |||||||
| 1665 | ). | ||||||
| 1666 | ' printf("%s}\n", indent);'."\n". | ||||||
| 1667 | |||||||
| 1668 | ' }'."\n". | ||||||
| 1669 | "}\n". | ||||||
| 1670 | |||||||
| 1671 | 'else {'."\n". | ||||||
| 1672 | ' printf("%s...\n", indent);'."\n". | ||||||
| 1673 | "}\n". | ||||||
| 1674 | |||||||
| 1675 | "}\n". | ||||||
| 1676 | |||||||
| 1677 | # post hook | ||||||
| 1678 | (exists $class->{'after'}->{'dump'} ? | ||||||
| 1679 | "{\n".$class->{'after'}->{'dump'}."\n}\n" : '') | ||||||
| 1680 | ); | ||||||
| 1681 | } | ||||||
| 1682 | } | ||||||
| 1683 | |||||||
| 1684 | #------------------------------------------------------------------------------- | ||||||
| 1685 | sub _get_init_c_code | ||||||
| 1686 | #------------------------------------------------------------------------------- | ||||||
| 1687 | { | ||||||
| 1688 | 0 | 0 | my ($self, $attrtype) = @_; | ||||
| 1689 | return | ||||||
| 1690 | 0 | 0 | (exists $self->{'classes'}->{$attrtype} ? | ||||
| 0 | |||||||
| 1691 | '(Object)NULL' : | ||||||
| 1692 | ($attrtype eq 'pthread_mutex_t' ? | ||||||
| 1693 | '(pthread_mutex_t)PTHREAD_MUTEX_INITIALIZER' : | ||||||
| 1694 | '('.$attrtype.')0')); | ||||||
| 1695 | } | ||||||
| 1696 | |||||||
| 1697 | #------------------------------------------------------------------------------- | ||||||
| 1698 | sub _define_destructors | ||||||
| 1699 | #------------------------------------------------------------------------------- | ||||||
| 1700 | { | ||||||
| 1701 | 0 | 0 | my ($self) = @_; | ||||
| 1702 | 0 | foreach my $classname (keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 1703 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 1704 | |||||||
| 1705 | 0 | 0 | $self->func( | ||||
| 0 | |||||||
| 1706 | 'delete(self:'.$classname.'):void', | ||||||
| 1707 | |||||||
| 1708 | # pre hook | ||||||
| 1709 | (exists $class->{'before'}->{'delete'} ? | ||||||
| 1710 | "{\n".$class->{'before'}->{'delete'}."\n}\n" : ''). | ||||||
| 1711 | |||||||
| 1712 | 'free(('.$self->_get_c_typename($classname).')(self->data));'."\n". | ||||||
| 1713 | 'free(self);'."\n". | ||||||
| 1714 | |||||||
| 1715 | # post hook | ||||||
| 1716 | (exists $class->{'after'}->{'delete'} ? | ||||||
| 1717 | "{\n".$class->{'after'}->{'delete'}."\n}\n" : '') | ||||||
| 1718 | ); | ||||||
| 1719 | } | ||||||
| 1720 | } | ||||||
| 1721 | |||||||
| 1722 | #------------------------------------------------------------------------------- | ||||||
| 1723 | sub _define_accessors | ||||||
| 1724 | #------------------------------------------------------------------------------- | ||||||
| 1725 | { | ||||||
| 1726 | 0 | 0 | my ($self) = @_; | ||||
| 1727 | 0 | foreach my $classname (keys %{$self->{'classes'}}) { | |||||
| 0 | |||||||
| 1728 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 1729 | 0 | foreach my $attrname (keys %{$class->{'attr'}}) { | |||||
| 0 | |||||||
| 1730 | #my $attrtype = $self->_get_c_attrtype($class->{'attr'}->{$attrname}); | ||||||
| 1731 | 0 | my $attrtype = $class->{'attr'}->{$attrname}; | |||||
| 1732 | |||||||
| 1733 | # getter | ||||||
| 1734 | 0 | $self->meth( | |||||
| 1735 | $classname, | ||||||
| 1736 | 'get'.ucfirst($attrname).'():'.$attrtype, | ||||||
| 1737 | 'return (('.$self->_get_c_typename($classname).')(self->data))->CCC_'.$attrname.';', | ||||||
| 1738 | ); | ||||||
| 1739 | |||||||
| 1740 | # getter to pointer | ||||||
| 1741 | 0 | 0 | $self->meth( | ||||
| 1742 | $classname, | ||||||
| 1743 | 'get'.ucfirst($attrname).'Ptr():'. | ||||||
| 1744 | (exists $self->{'classes'}->{$attrtype} ? 'Object' : $attrtype).'*', | ||||||
| 1745 | |||||||
| 1746 | 'return &((('.$self->_get_c_typename($classname).')(self->data))->CCC_'.$attrname.');', | ||||||
| 1747 | ); | ||||||
| 1748 | |||||||
| 1749 | # setter | ||||||
| 1750 | 0 | $self->meth( | |||||
| 1751 | $classname, | ||||||
| 1752 | 'set'.ucfirst($attrname).'(value:'.$attrtype.'):void', | ||||||
| 1753 | '(('.$self->_get_c_typename($classname).')(self->data))->CCC_'.$attrname.' = value;', | ||||||
| 1754 | ); | ||||||
| 1755 | |||||||
| 1756 | # setter for pointer | ||||||
| 1757 | 0 | 0 | $self->meth( | ||||
| 1758 | $classname, | ||||||
| 1759 | 'set'.ucfirst($attrname).'Ptr(value:'. | ||||||
| 1760 | (exists $self->{'classes'}->{$attrtype} ? 'Object' : $attrtype).'*):void', | ||||||
| 1761 | |||||||
| 1762 | 'if (value == NULL) { printf("In set'.ucfirst($attrname).'Ptr(): cannot handle NULL pointer\n"); exit(1); }'."\n". | ||||||
| 1763 | '(('.$self->_get_c_typename($classname).')(self->data))->CCC_'.$attrname.' = *value;', | ||||||
| 1764 | ); | ||||||
| 1765 | } | ||||||
| 1766 | } | ||||||
| 1767 | } | ||||||
| 1768 | |||||||
| 1769 | #------------------------------------------------------------------------------- | ||||||
| 1770 | sub _get_c_typename | ||||||
| 1771 | #------------------------------------------------------------------------------- | ||||||
| 1772 | { | ||||||
| 1773 | 0 | 0 | my ($self, $type) = @_; | ||||
| 1774 | 0 | 0 | return (exists $self->{'classes'}->{$type} ? $self->{'prefix-types'}.$type : $type); | ||||
| 1775 | } | ||||||
| 1776 | |||||||
| 1777 | #------------------------------------------------------------------------------- | ||||||
| 1778 | sub _get_c_attrtype | ||||||
| 1779 | #------------------------------------------------------------------------------- | ||||||
| 1780 | { | ||||||
| 1781 | 0 | 0 | my ($self, $attrtype) = @_; | ||||
| 1782 | 0 | 0 | return (exists $self->{'classes'}->{$attrtype} ? 'Object' : $attrtype); | ||||
| 1783 | } | ||||||
| 1784 | |||||||
| 1785 | #------------------------------------------------------------------------------- | ||||||
| 1786 | sub _signature_to_string | ||||||
| 1787 | #------------------------------------------------------------------------------- | ||||||
| 1788 | { | ||||||
| 1789 | 0 | 0 | my ($self, $sign) = @_; | ||||
| 1790 | return | ||||||
| 1791 | 0 | $sign->{'name'}. | |||||
| 1792 | 0 | '('.join(',',map { $_->[0].':'.$_->[1] } @{$sign->{'params'}}).'):'. | |||||
| 0 | |||||||
| 1793 | $sign->{'returns'}; | ||||||
| 1794 | } | ||||||
| 1795 | |||||||
| 1796 | #------------------------------------------------------------------------------- | ||||||
| 1797 | sub _load_code_from_file | ||||||
| 1798 | #------------------------------------------------------------------------------- | ||||||
| 1799 | { | ||||||
| 1800 | 0 | 0 | my ($self, $code) = @_; | ||||
| 1801 | 0 | 0 | $code = '' unless defined $code; | ||||
| 1802 | 0 | 0 | 0 | if (($code =~ /^\.?\.?\/[^\*]/) || ($code !~ /\n/ && -f $code && -r $code)) { | |||
| 0 | |||||||
| 0 | |||||||
| 1803 | 0 | 0 | open SRCFILE, $code or die "Error: cannot open source file '$code': $!\n"; | ||||
| 1804 | 0 | $code = join '', |
|||||
| 1805 | 0 | close SRCFILE; | |||||
| 1806 | } | ||||||
| 1807 | 0 | $code =~ s/^[\s\t\n\r]*//g; | |||||
| 1808 | 0 | $code =~ s/[\s\t\n\r]*$//g; | |||||
| 1809 | 0 | $code =~ s/(\r?\n\r?)([^\s])/$1 $2/g; | |||||
| 1810 | |||||||
| 1811 | # experimental: replace "//..." comments with "/*...*/" | ||||||
| 1812 | 0 | $code =~ s/\/\/+(.*)$/\/*$1*\//mg; | |||||
| 1813 | |||||||
| 1814 | 0 | return $code; | |||||
| 1815 | } | ||||||
| 1816 | |||||||
| 1817 | #------------------------------------------------------------------------------- | ||||||
| 1818 | sub _get_parent_classes | ||||||
| 1819 | #------------------------------------------------------------------------------- | ||||||
| 1820 | { | ||||||
| 1821 | 0 | 0 | my ($self, $classname) = @_; | ||||
| 1822 | 0 | my @parents = (); | |||||
| 1823 | 0 | my @parents_parents = (); | |||||
| 1824 | 0 | my $class = $self->{'classes'}->{$classname}; | |||||
| 1825 | 0 | foreach my $name (@{$class->{'isa'}}) { | |||||
| 0 | |||||||
| 1826 | 0 | push @parents, $name; | |||||
| 1827 | 0 | push @parents_parents, $self->_get_parent_classes($name); | |||||
| 1828 | } | ||||||
| 1829 | 0 | push @parents, @parents_parents; | |||||
| 1830 | # delete dublicates | ||||||
| 1831 | 0 | my @clean = (); | |||||
| 1832 | 0 | map { | |||||
| 1833 | 0 | my $x = $_; | |||||
| 1834 | 0 | 0 | push(@clean, $x) unless scalar(grep { $x eq $_ } @clean); | ||||
| 0 | |||||||
| 1835 | } | ||||||
| 1836 | @parents; | ||||||
| 1837 | 0 | return @clean; | |||||
| 1838 | } | ||||||
| 1839 | |||||||
| 1840 | #------------------------------------------------------------------------------- | ||||||
| 1841 | 1; | ||||||
| 1842 | __END__ |