/scripts/const.pl

  1#!/usr/bin/perl -w
  2
  3# Since the sdl_const.pl and gl_const.pl scripts with 2.0-beta2 don't seem to
  4# work at all, this script takes SDL/Constans.pm and OpenGL/Constants.pm (as
  5# original from 2.0-beta2) and fixes them up, and moves them into ../lib/
  6
  7# I already did this for 1.20.2, so you need to run this only if you intent
  8# to rebuild the .pm files.
  9
 10# See http://Bloodgate.com/perl/sdl/sdl_perl.html
 11
 12use strict;
 13
 14##############################################################################
 15
 16my $sdl = read_file('SDL/Constants.pm');
 17
 18# remove 'main::' on subs
 19$sdl =~ s/sub main::([\w]+)/sub $1/g;
 20
 21# turn on () on subs to make peep optimizer to inline them
 22#$sdl =~ s/sub ([\w]+)\s+{/sub $1 () {/g;
 23
 24write_file( '../lib/SDL/Constants.pm', insert_export($sdl) );
 25
 26undef $sdl;
 27
 28##############################################################################
 29
 30my $gl = read_file('OpenGL/Constants.pm');
 31
 32# remove 'main::' on subs
 33$gl =~ s/sub main::([\w]+)/sub $1/g;
 34
 35# turn on () on subs to make peep optimizer to inline them
 36#$gl =~ s/sub ([\w]+)\s+{/sub $1 () {/g;
 37
 38write_file(
 39	'../lib/SDL/OpenGL/Constants.pm',
 40	insert_export( $gl, grep_constants() )
 41);
 42
 431;
 44
 45sub read_file {
 46	my $file = shift;
 47
 48	print "Reading $file...";
 49	my $FILE;
 50	open $FILE, $file or die("Cannot read $file: $!\n");
 51	local $/; # slurp mode
 52	my $doc = <$FILE>;
 53	close $FILE;
 54	print "done.\n";
 55	$doc;
 56}
 57
 58sub write_file {
 59	my ( $file, $txt ) = @_;
 60
 61	print "Writing $file...";
 62	my $FILE;
 63	open $FILE, ">$file" or die("Cannot write $file: $!\n");
 64	print $FILE $txt;
 65	close $FILE;
 66	print "done.\n";
 67}
 68
 69sub insert_export {
 70	my $txt = shift;
 71
 72	my @sub = ();
 73
 74	# gather all sub names
 75	$txt =~ s/sub ([\w]+)\s+/push @sub, $1; 'sub ' . $1 . ' '/eg;
 76
 77	# if we got a second list of names, parse it and include anything that isn't
 78	# alreay in
 79
 80	my $add = "";
 81	if ( ref( $_[0] ) eq 'ARRAY' ) {
 82		my $const = shift;
 83		foreach my $c ( sort @$const ) {
 84			if ( grep ( /^$c->[0]$/, @sub ) == 0 ) {
 85				print "Adding $c->[0] $c->[1]\n";
 86				$add .= "sub $c->[0] () { $c->[1] }\n";
 87				push @sub, $c->[0];
 88			}
 89		}
 90		$add .= "\n";
 91	}
 92
 93	# SDL/Constants.pm contains doubles :-( So filter them out.
 94	my @sorted = sort @sub;
 95	my $last;
 96	@sub = ();
 97	my @doubles;
 98	foreach my $cur (@sorted) {
 99		if ( defined $last && $last eq $cur ) {
100
101			# double!
102			push @doubles, $last;
103		} else {
104			push @sub, $last if defined $last;
105		}
106		$last = $cur;
107	}
108	foreach my $cur (@doubles) {
109		$txt =~ s/\bsub $cur.*//g; # remove
110	}
111
112	my $export = "require Exporter;\nuse strict;\n";
113	$export .= "use vars qw/\$VERSION \@ISA \@EXPORT/;";
114	$export .= "\n\@ISA = qw/Exporter/;\n";
115
116	# this makes Exporter export the symbols from SDL::Constants to whatever
117	# package used SDL::Constants (usually SDL::Event.pm)
118	my $pack;
119	if ( $txt =~ /SDL::Constants/ ) {
120		$txt =~ s/SDL::Constants/SDL::Event/g;
121		$pack = 'SDL::Event';
122	}
123	if ( $txt =~ /SDL::OpenGL::Constants/ ) {
124		$txt =~ s/SDL::OpenGL::Constants/SDL::OpenGL/g;
125		$pack = 'SDL::OpenGL';
126	}
127	$export .= "\nsub import { $pack\->export_to_level(1, \@_); }\n";
128
129	$export .= "\n\@EXPORT = qw/\n";
130
131	my $line = "\t";
132	foreach my $s ( sort @sub ) {
133		if ( length($line) + length($s) > 70 ) {
134			$export .= "$line\n";
135			$line = "\t";
136		}
137		$line .= "$s ";
138	}
139	$export .= "$line /;\n";
140
141	# insert Exporter section
142	$txt =~ s/sub/$export\n\n$add\nsub/;
143
144	$txt;
145}
146
147sub grep_constants {
148
149	# grep all the OpenGL constants from SDL and return them
150
151	my $sdl_gl = read_file('/usr/include/GL/gl.h');
152
153	my @const = ();
154	$sdl_gl =~ s/^#define (GL_.*?)\s+(0x[\da-fA-F]+)/push @const,[$1,$2];/egm;
155
156	\@const;
157}
158
159END { print "\n"; }