File Coverage

blib/lib/ObjectivePerl/Parser.pm
Criterion Covered Total %
statement 9 92 9.7
branch 0 10 0.0
condition n/a
subroutine 3 19 15.7
pod n/a
total 12 121 9.9


line stmt bran cond sub pod time code
1             # ==========================================
2             # Copyright (C) 2004 kyle dawkins
3             # kyle-at-centralparksoftware.com
4             # ObjectivePerl is free software; you can
5             # redistribute and/or modify it under the
6             # same terms as perl itself.
7             # ==========================================
8              
9             package ObjectivePerl::Parser;
10 1     1   5 use strict;
  1         2  
  1         31  
11 1     1   6 use Carp;
  1         2  
  1         95  
12              
13             my $OBJP_START = "~[";
14             my $OBJP_START_MATCH_FOR_END = "[";
15             my $OBJP_END = "]";
16             my $OBJP_SUPER = 'super';
17              
18             #use IF::Log;
19 1     1   5 use Text::Balanced qw(extract_codeblock);
  1         1  
  1         2445  
20              
21             my $_parser;
22              
23             sub new {
24 0     0     my $className = shift;
25 0 0         return $_parser if $_parser;
26 0           my $self = {
27             _content => [],
28             _currentClass => "",
29             _classes => {},
30             };
31 0           bless $self, $className;
32 0           $_parser = $self;
33 0           return $self;
34             }
35              
36             sub initWithFile {
37 0     0     my $self = shift;
38 0           my $fullPath = shift;
39              
40 0           $self->setFullPath($fullPath);
41 0           $self->setSource(contentsOfFileAtPath($fullPath));
42 0           $self->parse();
43             }
44              
45             sub initWithString {
46 0     0     my $self = shift;
47 0           my $string = shift;
48              
49             # IF::Log::debug("Parser re-initialised with string ".substr($string, 0, 30)."...");
50 0           $self->setFullPath();
51 0           $self->setSource($string);
52 0           $self->setContent([]);
53 0           $self->parse();
54             #$self->dump();
55             }
56              
57             sub setFullPath {
58 0     0     my $self = shift;
59 0           $self->{_fullPath} = shift;
60             }
61              
62             sub fullPath {
63 0     0     my $self = shift;
64 0           return $self->{_fullPath};
65             }
66              
67             sub content {
68 0     0     my $self = shift;
69 0           return $self->{_content};
70             }
71              
72             sub setContent {
73 0     0     my $self = shift;
74 0           $self->{_content} = shift;
75             }
76              
77             sub contentElementAtIndex {
78 0     0     my $self = shift;
79 0           my $index = shift;
80 0           my $content = $self->content();
81 0           return $content->[$index];
82             }
83              
84             sub contentElementsInRange {
85 0     0     my $self = shift;
86 0           my $start = shift;
87 0           my $end = shift;
88 0           my $content = $self->content();
89 0           return [$content->[$start..$end]];
90             }
91              
92             sub contentElementCount {
93 0     0     my $self = shift;
94 0           return scalar @{$self->content()};
  0            
95             }
96              
97             sub source {
98 0     0     my $self = shift;
99 0           return $self->{_source};
100             }
101              
102             sub setSource {
103 0     0     my $self = shift;
104 0           $self->{_source} = shift;
105             }
106              
107             # This is a trick to allow the perl parser
108             # to take over again and import and parse use'd
109             # classes before continuing with this class
110             sub shouldSuspendParsing {
111 0     0     my $self = shift;
112 0           foreach my $contentElement (@{$self->content()}) {
  0            
113 0 0         return 1 if ($contentElement =~ /^no ObjectivePerl;$/m);
114             }
115 0           return 0;
116             }
117              
118             sub parse {
119 0     0     my $self = shift;
120 0           $self->stripComments();
121 0           $self->setContent([$self->source()]);
122 0           $self->parseImplementationDetails();
123 0 0         if ($self->shouldSuspendParsing()) {
124             # Suspending parsing to allow import of parent classes
125 0           return;
126             }
127 0           $self->breakIntoPackages();
128 0           $self->parseMethodDefinitions();
129 0           $self->parseMethodsForInstanceVariables();
130 0           $self->extractMessages();
131 0           $self->translateMessages();
132 0           $self->postProcess();
133             #$self->dump();
134             }
135              
136             sub stripComments {
137 0     0     my $self = shift;
138 0           my $source = $self->source();
139 0           $source =~ s/^\#OBJP/\!!OBJP/go;
140 0           $source =~ s/^\s*\#.*$//go;
141 0           $source =~ s/^!!OBJP/#OBJP/go;
142 0           $self->setSource($source);
143             }
144              
145             sub breakIntoPackages {
146 0     0     my $self = shift;
147 0           my $content = $self->content();
148 0           my $splitContent = [];
149 0           foreach my $contentElement (@$content) {
150 0           while (1) {
151 0 0         if ($contentElement =~ /^\s*(package\s+[A-Za-z0-9_:]+\s*;)/mo) {
152 0           my $packageDeclaration = $1;
153 0           $packageDeclaration =~ /package\s+([A-Za-z0-9_:]+)/o;
154 0           my $packageName = $1;
155 0 0         unless ($self->{_classes}->{$packageName}) {
156 0           $self->{_classes}->{$packageName} = { methods => {} };
157             }
158 0           my $quotedPackageDeclaration = quotemeta($packageDeclaration);
159 0           my ($beforePackage, $afterPackage) = split(/$quotedPackageDeclaration/, $contentElement, 2);
160 0           my $packageVariableDeclarations = "\n\n\$".$self->{_currentClass}."::".$OBJP_SUPER." = '_SUPER';\n";
161 0           push (@$splitContent, $beforePackage, $packageDeclaration, $packageVariableDeclarations);
162 0           $contentElement = $afterPackage;
163             } else {
164 0           push (@$splitContent, $contentElement);
165 0           last;
166             }
167             }
168             }
169 0           $self->setContent($splitContent);
170             }
171              
172             sub parseImplementationDetails {
173             my $self = shift;
174             foreach my $contentElement (@{$self->content()}) {
175             while ($contentElement =~ /^(\@(implementation|protocol) ([A-Za-z0-9_\:]+)( :\s*([A-Za-z0-9_\:]+))?\s*(\<\s*((([A-Za-z0-9_\:]+),?\s*)*)\s*\>)?\s*(($|\{(\s|$)*)(\s*(\@(private|protected):\s*)?\$[a-zA-Z0-9_]+\s*[;,]\s*($)?)*\})?)/mo) {
176             #print "1: $1\n2: $2\n3: $3\n4: $4\n5: $5\n6: $6\n7: $7\n8: $8\n9: $9\n10: $10\n";
177             my $substituteRegExp = quotemeta($1);
178             my $className = $3;
179             my $parentClassName = $5;
180             my $protocolList = $7 || "";
181             my $protocols = [split(/[, ]+/, $protocolList)];
182             my $instanceDeclarations = $10;
183             # (($|\{\s*$)(\s*\$[a-zA-Z0-9_]+\s*[;,]\s*($)?)*\})
184             my $newClassDefinition = $self->classDefinitionFromClassAndParentClassConformingToProtocols($className, $parentClassName, $protocols);
185             my $ivars = instanceVariablesFromInstanceDeclarations($10);
186              
187             $self->{_classes}->{$className} = {
188             parent => $parentClassName,
189             protocols => $protocols,
190             ivars => $ivars,
191             };
192             my $ivarDeclaration = "use ObjectivePerl::InstanceVariable;\n";
193             $ivarDeclaration .= "\$".$self->{_currentClass}."::objp_ivs = {\n";
194             foreach my $level qw(private protected) {
195             next unless ($ivars->{$level});
196             $ivarDeclaration .= "\t$level => [qw(".join(" ", @{$ivars->{$level}}).")],\n";
197             }
198             $ivarDeclaration .= "};\n";
199             $newClassDefinition = $newClassDefinition.$ivarDeclaration;
200             $contentElement =~ s/$substituteRegExp/$newClassDefinition/m;
201             }
202             $contentElement =~ s/^\@end/1;package main;\n/mg;
203             }
204             #$self->dump();
205             }
206              
207             sub parseMethodDefinitions {
208             my $self = shift;
209             foreach my $contentElement (@{$self->content()}) {
210             next if (ref $contentElement eq 'ARRAY');
211             #IF::Log::debug("Check element for methods: $contentElement");
212             if ($contentElement =~ /^package ([A-Za-z0-9_:]+);/m) {
213             $self->{_currentClass} = $1;
214             }
215             while ($contentElement =~ /^(([\+\-])\s*(\([a-zA-Z]+\))?\s*([a-zA-Z0-9_]+[^\{]*{))/mo) {
216             my $methodType = "INSTANCE";
217             my $methodLine = quotemeta("$1");
218             my $methodDeclaration = $4;
219             my $returnType = $3;
220             if ($2 eq "+") {
221             $methodType = "STATIC";
222             }
223              
224             my $newMethodDefinition = methodDefinitionFromMethodTypeAndDeclaration(
225             $methodType, $methodDeclaration);
226             if ($returnType) {
227             $returnType =~ s/[()]//g;
228             $newMethodDefinition->{returnType} = $returnType;
229             }
230             if ($self->{_classes}->{$self->{_currentClass}}->{methods}->{$newMethodDefinition->{signature}}) {
231             #IF::Log::dump($self->{_classes}->{$self->{_currentClass}}->{methods});
232             croak("Warning, redefinition of method shown here: ".$newMethodDefinition->{signature}." in class ".$self->{_currentClass});
233             }
234             $self->{_classes}->{$self->{_currentClass}}->{methods}->{$newMethodDefinition->{signature}} = $newMethodDefinition;
235             my $methodSignature = $newMethodDefinition->{signature};
236             if ($self->camelBonesCompatibility()) {
237             my $selector = $newMethodDefinition->{signature};
238             $selector =~ s/_/:/g;
239             $selector .= ":"; #??
240             $methodSignature .= " : Selector($selector)";
241             if ($newMethodDefinition->{argumentTypes}) {
242             my $argumentList = "";
243             foreach my $argumentType (@{$newMethodDefinition->{argumentTypes}}) {
244             $argumentList .= argumentTypeCharacterFromArgumentTypeName($argumentType);
245             }
246             $methodSignature .= " ArgTypes($argumentList)";
247             }
248             if ($newMethodDefinition->{returnType}) {
249             $methodSignature .= " ReturnType(".argumentTypeCharacterFromArgumentTypeName($newMethodDefinition->{returnType}).")";
250             }
251             }
252             my $newMethodLine = "sub ".$methodSignature." {\n";
253             $newMethodLine .= "\tmy (".join(", ", '$objp_self', @{$newMethodDefinition->{arguments}}).") = \@_;\n";
254             if ($newMethodDefinition->{type} eq "INSTANCE") {
255             $newMethodLine .= "\tmy \$self = \$objp_self;\n";
256             } else {
257             $newMethodLine .= "\tmy \$className = \$objp_self;\n";
258             }
259             $newMethodLine .= "#OPIV\n";
260             $contentElement =~ s/$methodLine/$newMethodLine/g;
261             }
262             }
263             }
264              
265             sub parseMethodsForInstanceVariables {
266             my $self = shift;
267             foreach my $contentElement (@{$self->content()}) {
268             next if (ref $contentElement eq 'ARRAY');
269             if ($contentElement =~ /^package ([A-Za-z0-9_:]+);/mo) {
270             $self->{_currentClass} = $1;
271             }
272             my $foundMethods = [];
273             while ($contentElement =~ /^\s*sub ([a-zA-Z0-9_]+)([^\{]|$)*{/mgo) {
274             push (@$foundMethods, $1);
275             }
276              
277             foreach my $methodName (@$foundMethods) {
278             #print $methodName."\n";
279             my $methodDefinition = $self->{_classes}->{$self->{_currentClass}}->{methods}->{$methodName};
280             my $isInstanceMethod;
281             if ($methodDefinition) {
282             #IF::Log::dump($methodDefinition);
283             $isInstanceMethod = ($methodDefinition->{type} eq "INSTANCE");
284             }
285             my ($beforeSub, $afterSub) = split(/^sub $methodName.?[^\{]*/sm, $contentElement, 2);
286             my @stuff = extract_codeblock($afterSub, '{}');
287             my $methodBlock = $stuff[0];
288            
289             if ($methodBlock) {
290             my $originalCode = quotemeta($methodBlock);
291            
292             # look through the method for ivar uses
293             # also here is where we *would* check for visibility rules. Right now,
294             # all ivars are considered "protected"
295            
296             my $ivars = {};
297             my $currentClass = $self->{_currentClass};
298             my $visitedClasses = { $currentClass => 1 };
299             foreach my $level qw(private protected) {
300             next unless $self->{_classes}->{$currentClass}->{ivars}->{$level};
301             $ivars->{$level} = [] unless $ivars->{$level};
302             push (@{$ivars->{$level}}, @{$self->{_classes}->{$currentClass}->{ivars}->{$level}});
303             }
304             while ($currentClass = $self->{_classes}->{$currentClass}->{parent}) {
305             last if ($visitedClasses->{$currentClass});
306             foreach my $level qw(protected) { # eventually we'll add public but for now no
307             next unless $self->{_classes}->{$currentClass}->{ivars}->{$level};
308             $ivars->{$level} = [] unless $ivars->{$level};
309             push (@{$ivars->{$level}}, @{$self->{_classes}->{$currentClass}->{ivars}->{$level}});
310             }
311             $visitedClasses->{$currentClass}++;
312             }
313            
314             my $usedIvars = [];
315             foreach my $level qw(private protected) {
316             foreach my $ivar (@{$ivars->{$level}}) {
317             my $quotedIvar = quotemeta($ivar);
318             if ($methodBlock =~ /$quotedIvar/) {
319             push (@$usedIvars, $ivar);
320             }
321             my $arguments = $methodDefinition? $methodDefinition->{arguments} : [];
322             foreach my $argument (@$arguments) {
323             if ($ivar eq $argument) {
324             croak "Can't have argument with the same name as instance variable $ivar\nin method $methodName";
325             }
326             }
327             }
328             }
329              
330             my $ivarImports = "";
331             if (@$usedIvars && $isInstanceMethod) {
332             foreach my $ivar (@$usedIvars) {
333             (my $hashKey = $ivar) =~ s/\$//;
334              
335             $ivarImports .= qq(\tmy $ivar; tie $ivar, "ObjectivePerl::InstanceVariable", \$self, "$hashKey";\n);
336             # there *has* to be a way to do this with typeglobs:
337             #(my $glob = $ivar) =~ s/\$/\*/;
338             #$ivarImports .= qq(\t$glob = \\\${\$objp_self->{_v}->{$hashKey}};\n);
339             }
340             }
341            
342             $methodBlock =~ s/^#OPIV/$ivarImports/gsm;
343             $contentElement =~ s/$originalCode/$methodBlock/;
344             } else {
345             print "Couldn't extract method block for $methodName\n";
346             }
347             }
348             }
349             }
350              
351             sub translateMessages {
352             my $self = shift;
353             my $content = $self->content();
354             foreach my $contentElement (@$content) {
355             next unless ref $contentElement eq 'ARRAY';
356             $contentElement = messageInvocationForContentElements($contentElement);
357             }
358             }
359              
360             sub messageInvocationForContentElements {
361             my $contentElements = shift;
362              
363             my $message;
364             foreach my $contentElement (@$contentElements) {
365             if (ref $contentElement eq 'ARRAY') {
366             $contentElement = messageInvocationForContentElements($contentElement);
367             }
368             $message .= $contentElement;
369             }
370            
371             my $receiver = extractDelimitedChunkTerminatedBy($message, " ");
372             my $quotedReceiver = quotemeta($receiver);
373             $message =~ s/$quotedReceiver\s*//;
374              
375             my $messageName = extractDelimitedChunkTerminatedBy($message, ":");
376             my $quotedMessageName = quotemeta($messageName);
377             $message =~ s/$quotedMessageName[:]?\s*//;
378              
379             my $selectorArray = "";
380             my $selectors = [];
381             if ($message ne '') {
382             # looks like we have selectors
383              
384             my $argument = extractDelimitedChunkTerminatedBy($message, " ");
385             push (@$selectors, { key => "$messageName", value => $argument });
386             my $quotedArgument = quotemeta($argument);
387             $message =~ s/$quotedArgument\s*//;
388             while ($message ne '') {
389             #IF::Log::debug("MESSAGE: $message");
390             my $selector = extractDelimitedChunkTerminatedBy($message, ":");
391             my $quotedSelector = quotemeta($selector);
392             $message =~ s/$quotedSelector[:]\s*//;
393             my $argument = extractDelimitedChunkTerminatedBy($message, " ");
394             if ($selector eq "") {
395             $selector = "_";
396             }
397             push (@$selectors, { key => "$selector", value => $argument });
398             my $quotedArgument = quotemeta($argument);
399             $message =~ s/$quotedArgument\s*//;
400             }
401              
402             $selectorArray = "[\n";
403             foreach my $selector (@$selectors) {
404             $selector->{key} = quoteIfNecessary($selector->{key});
405             $selectorArray .= "\t{ key => ".$selector->{key}.", value => ".$selector->{value}." },\n";
406             }
407             $selectorArray .= "]";
408             }
409              
410             if ($receiver eq '$'.$OBJP_SUPER) {
411             if ($messageName =~ /^[A-Za-z0-9_]+$/o) {
412             my $methodName = ObjectivePerl::Runtime::messageSignatureFromMessageAndSelectors(
413             $messageName, $selectors);
414             return '$objp_self->SUPER::'.$methodName.'('.join(",", map {$_->{value}} @$selectors).')';
415             } else {
416             # we need to use eval() to figure this one out...
417             croak "Can't call super with dynamic message name";
418             }
419             }
420             $messageName = quoteIfNecessary($messageName);
421             $receiver = quoteIfNecessary($receiver);
422             return "ObjectivePerl::Runtime->ObjpMsgSend($receiver, $messageName, $selectorArray)";
423             }
424              
425             sub quoteIfNecessary {
426             my $string = shift;
427             if ($string =~ /^[A-Za-z0-9_i:]+$/) {
428             $string = '"'.$string.'"';
429             }
430             return $string;
431             }
432              
433             sub extractMessages {
434             my $self = shift;
435             $self->setContent(extractMessagesFromSource(join("", @{$self->content()})));
436             }
437              
438             sub extractMessagesFromSource {
439             my $source = shift;
440             my $content = [];
441             #IF::Log::debug("Extracting messages from $source");
442             my $start = quotemeta($OBJP_START);
443             my $end = quotemeta($OBJP_END);
444             while ($source =~ /$start/i) {
445             (my $beforeTag, my $afterTag) = split(/$start/, $source, 2);
446             push (@$content, $beforeTag) unless $beforeTag eq "";
447             my ($beforeEnd, $afterEnd) = splitSourceOnMessageEnd($afterTag);
448             if ($beforeEnd =~ / /) {
449             push (@$content, extractMessagesFromSource($beforeEnd));
450             } else {
451             push (@$content, $OBJP_START.$beforeEnd.$OBJP_END);
452             }
453             $source = $afterEnd;
454             }
455             push (@$content, $source);
456             return $content;
457             }
458              
459             sub dump {
460             my $self = shift;
461             my @lines = split(/\n/, join("", @{$self->content()}));
462             my $lineNumber = 1;
463             foreach my $line (@lines) {
464             print sprintf("%03d: %s\n", $lineNumber++, $line);
465             }
466             }
467              
468             sub debug {
469             my $self = shift;
470             return $self->{_debug};
471             }
472              
473             sub setDebug {
474             my $self = shift;
475             $self->{_debug} = shift;
476             }
477              
478             sub camelBonesCompatibility {
479             my $self = shift;
480             return $self->{_camelBonesCompatibility};
481             }
482              
483             sub setCamelBonesCompatibility {
484             my $self = shift;
485             $self->{_camelBonesCompatibility} = shift;
486             }
487              
488             # static methods:
489              
490             sub splitSourceOnMessageEnd {
491             my $source = shift;
492             my $start = quotemeta($OBJP_START);
493             my $startMatchForEnd = "$start|".quotemeta($OBJP_START_MATCH_FOR_END);
494             my $end = quotemeta($OBJP_END);
495             my $startSource = "";
496             my $tagDepth = 1;
497             while (1) {
498             $source =~ /($startMatchForEnd)/;
499             my $startingMatch = $1;
500             my @lookingForStart = split(/$startMatchForEnd/i, $source, 2);
501             my @lookingForEnd = split(/$end/i, $source, 2);
502              
503             if ($#lookingForStart == 0 && $#lookingForEnd == 0) {
504             croak (">>> Error parsing objp no matching ".$OBJP_END);
505             return (undef, undef);
506             }
507              
508             if (length($lookingForEnd[0]) < length($lookingForStart[0])) {
509             $tagDepth -= 1;
510             $source = $lookingForEnd[1];
511             $startSource .= $lookingForEnd[0];
512             if ($tagDepth > 0) {
513             $startSource .= $OBJP_END;
514             }
515             } else {
516             $tagDepth += 1;
517             $source = $lookingForStart[1];
518             $startSource .= $lookingForStart[0].$startingMatch;
519             }
520              
521             if ($tagDepth <= 0) {
522             return ($startSource, $source);
523             }
524             }
525             }
526              
527             sub contentsOfFileAtPath {
528             my $fullPathToFile = shift;
529            
530             if (open (FILE, $fullPathToFile)) {
531             my $contents = join("", );
532             close (FILE);
533             return $contents;
534             } else {
535             croak("Error opening $fullPathToFile");
536             return;
537             }
538             }
539              
540             sub methodDefinitionFromMethodTypeAndDeclaration {
541             my $type = shift;
542             my $declaration = shift;
543            
544             my $declarationParts = [];
545             my $arguments = [];
546             my $methodDefinition = { type => $type };
547             my $argumentTypes = [];
548            
549             while ($declaration =~ /^([a-zA-Z0-9_]*)(:|\s|$)/) {
550             my $part = $1;
551             my $end = $2;
552              
553             push (@$declarationParts, $part);
554             $declaration =~ s/^[a-zA-Z0-9_]*:?\s*//g;
555             last unless ($end eq ":");
556              
557             if ($declaration =~ /^\s*\(([^)]+)\)/) {
558             push (@$argumentTypes, $1);
559             $declaration =~ s/^\s*\([^)]+\)\s*//g;
560             } else {
561             push (@$argumentTypes, "id");
562             }
563              
564             $declaration =~ s/^\s*(\$[a-zA-Z0-9_]+)\s*//g;
565             push (@$arguments, $1);
566             }
567              
568             $methodDefinition->{selectors} = $declarationParts;
569             $methodDefinition->{arguments} = $arguments;
570             $methodDefinition->{argumentTypes} = $argumentTypes;
571             $methodDefinition->{signature} = join("_", @$declarationParts);
572             return $methodDefinition;
573             }
574              
575             sub classDefinitionFromClassAndParentClassConformingToProtocols {
576             my ($self, $className, $parentClassName, $protocols) = @_;
577              
578             my $definition = "package $className;\n";
579             $definition .= "use strict;\nuse vars qw(\@ISA \$".$OBJP_SUPER.");\nuse ObjectivePerl::Object;\n";
580             my @isa = ();
581             if ($parentClassName) {
582             unless ($self->{_classes}->{$parentClassName}) {
583             $definition .= "no ObjectivePerl;\n";
584             $definition .= "use $parentClassName;\n";
585             }
586             #eval "use $parentClassName;"; # huh?!
587             push (@isa, $parentClassName);
588             }
589             foreach my $protocol (@$protocols) {
590             push (@isa, $protocol);
591             $definition .= "use $protocol;\n";
592             }
593             if ($parentClassName && !$self->{_classes}->{$parentClassName}) {
594             $definition .= "use ObjectivePerl class => '$className';\npackage $className;\n";
595             }
596             #$definition .= "package $className;\n"; # just to re-set the parser to the right package
597             # add our own root entity class to the @isa tree:
598             push (@isa, "ObjectivePerl::Object");
599             $definition .= "\@ISA = qw(".join(" ", @isa).");\n\n";
600             return $definition;
601             }
602              
603             sub postProcess {
604             my $self = shift;
605             if ($self->debug() & $ObjectivePerl::DEBUG_SOURCE) {
606             my $isDumping = 0;
607             my @lines = split(/\n/, join("", @{$self->content()}));
608             my $lineNumber = 1;
609             foreach my $line (@lines) {
610             if ($line =~ /OBJP_DEBUG_START/) {
611             $isDumping = 1;
612             }
613             if ($line =~ /OBJP_DEBUG_END/) {
614             $isDumping= 0;
615             }
616             print STDOUT sprintf("%04d: %s\n", $lineNumber, $line) if $isDumping;
617             $lineNumber++;
618             }
619             }
620             }
621              
622             sub instanceVariablesFromInstanceDeclarations {
623             my $instanceDeclarations = shift || "";
624             my $instanceVariables = {};
625              
626             # split into visibility levels first
627             my @parts = split(/\@/, $instanceDeclarations);
628             my $visibilitySections = {};
629             foreach my $part (@parts) {
630             unless ($part =~ /^(private|protected)(.*)$/mso) {
631             push (@{$visibilitySections->{protected}}, $part);
632             next;
633             }
634             push (@{$visibilitySections->{$1}}, $2);
635             }
636            
637             foreach my $level (keys %$visibilitySections) {
638             foreach my $part (@{$visibilitySections->{$level}}) {
639             while ($part =~ /(\$[A-Za-z0-9_]+)/g) {
640             push (@{$instanceVariables->{$level}}, $1);
641             }
642             }
643             }
644             #IF::Log::dump($instanceVariables);
645             return $instanceVariables;
646             }
647              
648             # LAME: there must be a better way
649             sub extractDelimitedChunkTerminatedBy {
650             my $chunk = shift;
651             my $terminator = shift;
652             my $extracted = "";
653             my $balanced = {};
654             my $isQuoting = 0;
655             my $outerQuoteChar = '';
656              
657             my @chars = split(//, $chunk);
658             for (my $i = 0; $i <= $#chars; $i++) {
659             my $charAt = $chars[$i];
660              
661             if ($charAt eq '\\') {
662             $extracted .= $chars[$i].$chars[$i+1];
663             $i++;
664             next;
665             }
666             if ($charAt =~ /$terminator/) {
667             if (isBalanced($balanced)) {
668             return $extracted;
669             }
670             }
671              
672             unless ($isQuoting) {
673             if ($charAt =~ /["']/) { #'"
674             $isQuoting = 1;
675             $outerQuoteChar = $charAt;
676             $balanced->{$charAt} ++;
677             } elsif ($charAt =~ /[\[\{\(]/ ) {
678             $balanced->{$charAt} ++;
679             } elsif ($charAt eq ']') {
680             $balanced->{'['} --;
681             } elsif ($charAt eq '}') {
682             $balanced->{'{'} --;
683             } elsif ($charAt eq ')') {
684             $balanced->{'('} --;
685             }
686             } else {
687             if ($charAt eq $outerQuoteChar) {
688             $isQuoting = 0;
689             $outerQuoteChar = '';
690             $balanced->{$charAt} ++;
691             }
692             }
693              
694             $extracted .= $charAt;
695             }
696             if (isBalanced($balanced)) {
697             return $extracted;
698             } else {
699             croak "Error parsing message $chunk; unbalanced ".unbalanced($balanced);
700             }
701             return "";
702             }
703              
704             sub isBalanced {
705             my $balanced = shift;
706             foreach my $char (keys %$balanced) {
707             return 0 if ($char =~ /[\[\{\(]/ && $balanced->{$char} != 0);
708             return 0 if ($char =~ /["']/ && $balanced->{$char} % 2 != 0);
709             }
710             return 1;
711             }
712              
713             sub unbalanced {
714             my $balanced = shift;
715             foreach my $char (keys %$balanced) {
716             return $char if ($char =~ /[\[\{\(]/ && $balanced->{$char} != 0);
717             return $char if ($char =~ /["']/ && $balanced->{$char} % 2 != 0);
718             }
719             }
720              
721             sub argumentTypeCharacterFromArgumentTypeName {
722             my $typeName = shift;
723             return "@" if $typeName eq "id";
724             return "v" if $typeName eq "void";
725             return "i" if $typeName eq "int";
726             return "c" if $typeName eq "char";
727             return $typeName;
728             }
729              
730             1;