/scripts/const.pl

http://github.com/PerlGameDev/SDL · Perl · 159 lines · 96 code · 39 blank · 24 comment · 10 complexity · 3284ed59b1b978e77930e281e6596c61 MD5 · raw file

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