gambas-info-extract.pl

Gambas is a graphical development environment based on a Basic interpreter, like Visual Basic. It us

#!/usr/bin/perl
for $f (`ls /usr/lib/gambas-0.70b/lib/lib.gb*.la`) { 
    chomp $f; 
    $f =~ /lib\.(gb.*?)\.la/; 
    $l = $1;
    print "$l\n";
    $info = `gbi -f $l`;
    $info = " \n\n$info" if $info;
    @classes = split("\n\nCLASS ", $info);
    for $cls (@classes) {
	@lines = split(/\n/, $cls);
	$class = shift @lines;
	next unless $class =~ /\w/;
	$classorig = $class;
	$array = ($class =~ s/\[\]// ? 1 : 0);
	$dot = ($class =~ s/^\.// ? 1 : 0);
	my %USAGE;
	my $inherits;
	my $creatable;
	
	while ($line = shift @lines) {
	    if ($line =~ /^INHERITS\s+(\S+)/) {
		$inherits = $1;
	    } elsif ($line =~ /^CREATABLE/) {
		$creatable = 1;
	    } else {
		$sym = $line;
		$usage = shift @lines;
		$USAGE{$sym} = $usage;
	    }
	}
	$CLASS{$l}->{$class}->{'usage'} = \%USAGE;
	$CLASS{$l}->{$class}->{'creatable'} = $creatable;
	$CLASS{$l}->{$class}->{'inherits'} = $inherits;
	$CLASS{$l}->{$class}->{'dot'} = $dot; # means it's virtual
	$CLASS{$l}->{$class}->{'array'} = $array;
	$CLASS{$l}->{$class}->{'fullname'} = $classorig;
	$CLASS{$l}->{'fullnames'}->{$classorig} = $class;
	print ".";
    }
}

print "Got all the info files\n";

# after building the huge tree of crap, we assemble the wiki pages out of it
# remembering to grab inherited symbols when we do

# (this part i haven't written yet)

# anywhere there's a GetHelp call in gambas-component-extract, replace with %INCLUDE of appropriate symbol's page
# put the help in there, and the info description in the symbol's *Export page and %INCLUDE it from the symbol's page

for $comp (keys %CLASS) {
print "Editor contains: " . join(" ", sort keys %{$CLASS{'gb.qt.editor'}}) . "\n";
    for $cls (keys %{$CLASS{$comp}}) {
	%cls = %{%{$CLASS{$comp}}->{$cls}};
	$array = $cls{'array'};
	print "\n$cls{'fullname'} ";
	my @syms;
	my @usage;
	my @wiki;
	for $sym (sort keys %{$cls{'usage'}}) {
#	    print "[$sym] ";
	    push @syms, $sym;
	    push @usage, $cls{'usage'}->{$sym};
	    push @wiki, getWikiName(\%CLASS, $comp, $cls, $sym);
	    # make export file for symbol
	    # push symbol, info and wikiname into an array unless it starts with _
	}
	if ($cls{'inherits'} ne '') {
	    my $inherits = $cls{'inherits'};
	    $inherits =~ s/^\.//;
	    $inh = inheritedSymbol(\%CLASS, $comp, $cls{'inherits'}) or die;
	    print "[$cls{'fullname'} inherits $cls{'inherits'}, got $inh]\n";

#	    print "No symbols found in $inh/$cls{'inherits'}\n" if (!defined $CLASS{$inh}->{$cls{'inherits'}}->{'fullname'});
#	    $inherits = $cls{'inherits'};
	    %inh = ( defined %{$CLASS{$inh}}->{$inherits} ? %{%{$CLASS{$inh}}->{$inherits}} : {} );
#	    print "Symbols: " . join(" ", sort keys %{$inh{'usage'}}) . "\n" if $inherits =~ /Array/;

	    for $sym (sort keys %{$inh{'usage'}}) {
		push @syms, $sym;
		push @usage, $inh{'usage'}->{$sym};
		push @wiki, getWikiName(\%CLASS, $inh, $inherits, $sym);
		# don't make export file, just push into array(s)
	    }
#	    print join(" ", @syms), "\n" if $inherits =~ /Array/;
	}
	# compose 4 symbol lists (properties, methods, events, constants) by sorting array and checking info entry
	# for which list, also static or not
	my %E;
	my %C;
	my %P;
	my %F;
	my %EW;
	my %CW;
	my %PW;
	my %FW;
	while (my $sym = shift @syms) {
	    my $usage = shift @usage;
	    my $wiki = shift @wiki;
	    if ($usage =~ /EVENT/) {
		$E{$sym} = $usage;
		$EW{$sym} = $wiki;
	    } elsif ($usage =~ /CONST/) {
		$C{$sym} = $usage;
		$CW{$sym} = $wiki;
	    } elsif ($usage =~ /PROPERTY/) {
		$P{$sym} = $usage;
		$PW{$sym} = $wiki;
	    } else {
		$F{$sym} = $usage;
		$FW{$sym} = $wiki;
	    }
	}
	my $arr = ($array ? "Array" : "");
	my $outfile = ">/tmp/gambas-info-extract/" . getWikiName(\%CLASS, $comp, $cls, undef) . "${arr}Export.txt";
#	print "$outfile\n" if $cls{'inherits'} =~ /Array/;
	open OUT, ">/tmp/gambas-info-extract/" . getWikiName(\%CLASS, $comp, $cls, undef) . "${arr}Export.txt";
	print OUT qq|<!---+<nop>$cls\n-->
---++Symbols
<table border=0 cellspacing=0 cellpadding=4><tr><th align=left width=120 bgcolor=%WEBBGCOLOR%>Events</th><th align=left width=120 bgcolor=%WEBBGCOLOR%>Properties</th><th align=left width=120 bgcolor=%WEBBGCOLOR%>Methods</th><th align=left width=120 bgcolor=%WEBBGCOLOR%>Constants</th></tr><tr>
|;

	print OUT "<td valign=top><table border=0 cellspacing=0 cellpadding=0><td valign=top>\n";
	my $i = 0;
	foreach my $e (sort keys %E) {
	    unless ($i++ % 10 > 0 && $i > 1) { print OUT "</td><td valign=top>"; }
	    next unless $EW{$e} ne '';
	    my $static = '&nbsp;' . qq|:\::$E{$e}:\::[[GambasMethodsDeclaration][<IMG border=0 valign=absmiddle SRC="%ATTACHURLPATH%/../GambasListOfComponentIcons/staticsymbol.png">]]| if $E{$e} =~ /STATIC/;
	    $n = $e;
	    $n =~ s/[^A-Za-z0-9]//g;
	    print OUT "<nobr>[[$EW{$e}][$n]]$static&nbsp;</nobr><br>\n";
	    writeSym($EW{$e}, $n, $E{$e});
	}
	print OUT "&nbsp;</td></table></td>\n";

	my $i = 0;
	print OUT "<td valign=top><table border=0 cellspacing=0 cellpadding=0><td valign=top>\n";
	foreach my $p (sort keys %P) {
	    unless ($i++ % 10 > 0 && $i > 1) { print OUT "</td><td valign=top>"; }
	    next unless $PW{$p} ne '';
	    my $static = '&nbsp;' . qq|[[GambasMethodsDeclaration][<IMG border=0 valign=absmiddle SRC="%ATTACHURLPATH%/../GambasListOfComponentIcons/staticsymbol.png">]]| if $P{$p} =~ /STATIC/;
	    $n = $p;
	    $n =~ s/[^A-Za-z0-9]//g;
	    print OUT "<nobr>[[$PW{$p}][$n]]$static&nbsp;</nobr><br>\n";
	    writeSym($PW{$p}, $n, $P{$p});
	}
	print OUT "&nbsp;</td></table></td>\n";

	my $i = 0;
	print OUT "<td valign=top><table border=0 cellspacing=0 cellpadding=0><td valign=top>\n";
	foreach my $f (sort keys %F) {
#	    print "[$sym $wiki $usage] " if $cls{'inherits'} =~ /Array/;
	    print "Got function $f pointing to $FW{$f}\n" if $cls{'inherits'} =~ /Array/;
	    unless ($i++ % 10 > 0 && $i > 1) { print OUT "</td><td valign=top>"; }
	    next unless $FW{$f} ne '';
	    my $static = '&nbsp;' . qq|[[GambasMethodsDeclaration][<IMG border=0 valign=absmiddle SRC="%ATTACHURLPATH%/../GambasListOfComponentIcons/staticsymbol.png">]]| if $F{$f} =~ /STATIC/;
	    $n = $f;
	    $n =~ s/[^A-Za-z0-9]//g;
	    print OUT "<nobr>[[$FW{$f}][$n]]$static&nbsp;</nobr><br>\n";
#	    print "<nobr>[[$FW{$f}][$n]]$static&nbsp;</nobr><br>\n" if $cls{'inherits'} =~ /Array/;
	    writeSym($FW{$f}, $n, $F{$f});
	}
	print OUT "&nbsp;</td></table></td>\n";

	my $i = 0;
	print OUT "<td valign=top><table border=0 cellspacing=0 cellpadding=0><td valign=top>\n";
	foreach my $c (sort keys %C) {
	    unless ($i++ % 10 > 0 && $i > 1) { print OUT "</td><td valign=top>"; }
	    next unless $CW{$c} ne '';
	    $n = $c;
	    $n =~ s/[^A-Za-z0-9]//g;
	    print OUT "[[$CW{$c}][$n]]&nbsp;<br>\n";	
	    writeSym($CW{$c}, $n, $C{$c}, 1);
	}
	print OUT "&nbsp;</td></table></td>\n";

	print OUT "</table>\n";
	close OUT;

    }
}

for $comp (keys %CLASS) {
    my %output;
    my %output2;
    @classes = sort keys %{$CLASS{$comp}};
    print "Classes for $comp: " . join(" ", @classes) . "\n";
    $origcomp = $comp;
    $comp =~ s/^gb\.//;
    $comp =~ s/\.(\w)/uc($1)/eg;
    $comp =~ s/^(\w)/uc($1)/e;
    open OUT, ">/tmp/gambas-info-extract/GambasComponent${comp}Export.txt\n";
    print OUT "<!---+<nop>$comp\n-->";
    for my $f (@classes) {
	next if $f eq 'fullnames';
	my $full = getWikiName(\%CLASS, $origcomp, $f, undef);
	$full .= "Array" if $CLASS{$origcomp}->{$f}->{'array'};
	if (my $p = findparentof(\%CLASS, $origcomp, $f)) {
	    $output2{$p} .= "\t\t* [[$full][$f]]\n";
	} else {
	    $output{$f} = "\t* [[$full][$f]]\n";
	}
	print $output{$f} if $f =~ /Control/;
    }
    for $o (sort keys %output) {
	print OUT $output{$o}, $output2{$o};
    }
    close OUT;
}

sub findparentof { # looking for child classes, not inherited symbols
    my $CLASS = shift;
    my $comp = shift;
    my $cls = shift;
    my %CLASS = %$CLASS;
    my $clslist = $CLASS{$comp};
    @cls = sort keys %$clslist;
    my @usedby;
    for my $c (@cls) {
	my $us = %{$CLASS{$comp}}->{$c}->{'usage'};
	for my $u (sort keys %$us) {
	    if ($us->{$u} =~ /as\s+\.?$cls$/i) {
		push @usedby, $c;
	    } else {
#		print "no match: $c vs $cls ($us->{$u})\n";
	    }
	}
    }

    return undef if $#usedby != 0;
#    print "$cls is used by $usedby[0]\n";
    return $usedby[0];
}

sub writeSym {
    my $wiki = shift;
    my $name = shift;
    my $usage = shift;
    my $const = shift;
    $const = "Constant" if $const;
    my $filename = "/tmp/gambas-info-extract/${wiki}${const}Export.txt";
    return undef if -f $filename;
    open SYM, ">$filename";
    print SYM qq|<table><th bgcolor=%WEBBGCOLOR%>$usage</th></table>
<nopublish>
<!-- DO NOT EDIT THIS FILE!  It will be overwritten after each change to the Gambas language. -->
</nopublish>
|;
    close SYM;
}

sub inheritedSymbol {
    my $CLASS = shift;
    my $comp = shift;
    my $cls = shift;
    my %CLASS = %$CLASS;
    my @comps = keys %CLASS;
    my @parents;
    my $par;
    while (my $cmp = shift @comps) {
	push @parents, $cmp if $comp =~ /$cmp/;
    }
    for $par (sort {$b <=> $a} @parents) {
	if (defined $CLASS{$par}->{'fullnames'}->{$cls}) {
	    return $par;
	}
    }
}

sub getWikiName {
    my $CLASS = shift;
    my $comp = shift;
    my $cls = shift;
    my $sym = shift;
    return undef unless goodSymbol($sym);
    my %CLASS = %$CLASS;
    my $wiki = "GambasComponent";
    my $type;
    $type = "Event" if $CLASS{$comp}->{$cls}->{'usage'}->{$sym} =~ /EVENT/;
    $type = "Constant" if $CLASS{$comp}->{$cls}->{'usage'}->{$sym} =~ /CONST/;
    $comp =~ s/^gb\.//;
    $comp =~ s/\.(\w)/uc($1)/eg;
    $comp =~ s/^(\w)/uc($1)/e;
    $wiki .= $comp;
#    $wiki .= mixedCase($cls); # classes already in mixed case
    $cls =~ s/[^A-Za-z0-9]//g;
    $cls =~ s/^(\w)/uc($1)/e;
    $wiki .= $cls;
    $wiki .= $type;
    $sym =~ s/[^A-Za-z0-9]//g;
    $wiki .= $sym; # symbols already in mixed case
#    $wiki .= "Export";
    # we don't want to include Export because we wouldn't be linking directly to it
    return $wiki;
}

sub goodSymbol {
    my $sym = shift;
    return 1 if $sym =~ /^\:?[A-Za-z0-9]+$/;
    my @good = qw(_new _call _get _put _free);
    my %good = map { $good{$_} => 1 } @good;
    return $good{$sym} + 0;
}

sub mixedCase {
    my $input = shift;
    return "" unless $input;
    return uc($input) unless length($input) > 1;
    $input = uc(substr($input, 0, 1)) . lc(substr($input, 1));
    return $input;
}