← Back to branch summary

~ubuntu-branches/ubuntu/lucid/glew/lucid-201002122355

« back to all changes in this revision

Viewing changes to auto/lib/OpenGL/Spec.pm

  • Committer: Bazaar Package Importer
  • Author(s): Muharem Hrnjadovic
  • Date: 2009-06-04 12:12:40 UTC
  • mfrom: (1.1.6 upstream) (2.1.3 squeeze)
  • Revision ID: james.westby@ubuntu.com-20090604121240-e0rh5kfvft8wh2b0
Tags: 1.5.1-4ubuntu1
* Merge from debian unstable, remaining changes:
  - Build shared libraries with CC, not LD.
  - The debian Makefile had trailing '^M' characters; once sanitized
    the diff between the debian/ubuntu Makefile looks as follows:
    http://pastebin.ca/1447378

Show diffs side-by-side

added added

removed removed

Lines of Context:
auto/lib/OpenGL/Spec.pm
1
 
package OpenGL::Spec;
2
 
 
3
 
# A very simple task further complicated by the fact that some people
4
 
# can't read, others use legacy Operating Systems, and others don't give
5
 
# a damn about using a halfway decent text editor.
6
 
#
7
 
# The code to parse the _template_ is so simple and straightforward...
8
 
# yet the code to parse the real spec files is this mess.
9
 
 
10
 
my %typemap = (
11
 
    bitfield    => "GLbitfield",
12
 
    boolean     => "GLboolean",
13
 
    # fsck up in EXT_vertex_array
14
 
    Boolean     => "GLboolean",
15
 
    byte        => "GLbyte",
16
 
    clampd      => "GLclampd",
17
 
    clampf      => "GLclampf",
18
 
    double      => "GLdouble",
19
 
    enum        => "GLenum",
20
 
    # Intel fsck up
21
 
    Glenum      => "GLenum",
22
 
    float       => "GLfloat",
23
 
    half        => "GLuint",
24
 
    int         => "GLint",
25
 
    short       => "GLshort",
26
 
    sizei       => "GLsizei",
27
 
    ubyte       => "GLubyte",
28
 
    uint        => "GLuint",
29
 
    ushort      => "GLushort",
30
 
    DMbuffer    => "void *",
31
 
 
32
 
    # ARB VBO introduces these
33
 
    sizeiptrARB => "GLsizeiptrARB",
34
 
    intptrARB   => "GLintptrARB",
35
 
 
36
 
    # ARB shader objects introduces these, charARB is at least 8 bits,
37
 
    # handleARB is at least 32 bits
38
 
    charARB     => "GLcharARB",
39
 
    handleARB   => "GLhandleARB",
40
 
 
41
 
    # GLX 1.3 defines new types which might not be available at compile time
42
 
    #GLXFBConfig   => "void*",
43
 
    #GLXFBConfigID => "XID",
44
 
    #GLXContextID  => "XID",
45
 
    #GLXWindow     => "XID",
46
 
    #GLXPbuffer    => "XID",
47
 
 
48
 
    # Weird stuff for some SGIX extension
49
 
    #GLXFBConfigSGIX   => "void*",
50
 
    #GLXFBConfigIDSGIX => "XID",
51
 
);
52
 
 
53
 
my %void_typemap = (
54
 
    void    => "GLvoid",
55
 
);
56
 
 
57
 
my $section_re  = qr{^[A-Z]};
58
 
my $function_re = qr{^(.+) ([a-z][a-z0-9_]*) \((.+)\)$}i;
59
 
my $token_re    = qr{^([A-Z0-9][A-Z0-9_]*):?\s+((?:0x)?[0-9A-F]+)(.*)$};
60
 
my $prefix_re   = qr{^(?:AGL | GLX | WGL)_}x;
61
 
my $eofnc_re    = qr{ \);?$ | ^$ }x;
62
 
my $function_re = qr{^(.+) ([a-z][a-z0-9_]*) \((.+)\)$}i;
63
 
my $prefix_re   = qr{^(?:gl | agl | wgl | glX)}x;
64
 
my $types_re    = __compile_wordlist_cap(keys %typemap);
65
 
my $voidtype_re = __compile_wordlist_cap(keys %void_typemap);
66
 
 
67
 
sub new($)
68
 
{
69
 
    my $class = shift;
70
 
    my $self = { section => {} };
71
 
    $self->{filename} = shift;
72
 
    local $/;
73
 
    open(my $fh, "<$self->{filename}") or die "Can't open $self->{filename}";
74
 
    my $content = <$fh>;
75
 
    my $section;
76
 
    my $s = $self->{section};
77
 
 
78
 
    $content =~ s{[ \t]+$}{}mg;
79
 
    # Join lines that end with a word-character and ones that *begin*
80
 
    # with one
81
 
    $content =~ s{(\w)\n(\w)}{$1 $2}sg;
82
 
 
83
 
    foreach (split /\n/, $content)
84
 
    {
85
 
        if (/$section_re/)
86
 
        {
87
 
            chomp;
88
 
            s/^Name String$/Name Strings/; # Fix common mistake
89
 
            $section = $_;
90
 
            $s->{$section} = "";
91
 
        }
92
 
        elsif (defined $section and exists $s->{$section})
93
 
        {
94
 
            s{^\s+}{}mg; # Remove leading whitespace
95
 
            $s->{$section} .= $_ . "\n";
96
 
        }
97
 
    }
98
 
 
99
 
    $s->{$_} =~ s{(?:^\n+|\n+$)}{}s foreach keys %$s;
100
 
 
101
 
    bless $self, $class;
102
 
}
103
 
 
104
 
sub sections()
105
 
{
106
 
    my $self = shift;
107
 
    keys %{$self->{section}};
108
 
}
109
 
 
110
 
sub name()
111
 
{
112
 
    my $self = shift;
113
 
    $self->{section}->{Name};
114
 
}
115
 
 
116
 
sub name_strings()
117
 
{
118
 
    my $self = shift;
119
 
    split("\n", $self->{section}->{"Name Strings"});
120
 
}
121
 
 
122
 
sub tokens()
123
 
{
124
 
    my $self = shift;
125
 
    my %tokens = ();
126
 
    foreach (split /\n/, $self->{section}->{"New Tokens"})
127
 
    {
128
 
        next unless /$token_re/;
129
 
        my ($name, $value) = ($1, $2);
130
 
        $name =~ s{^}{GL_} unless $name =~ /$prefix_re/;
131
 
        $tokens{$name} = $value;
132
 
    }
133
 
 
134
 
    return %tokens;
135
 
}
136
 
 
137
 
sub functions()
138
 
{
139
 
    my $self = shift;
140
 
    my %functions = ();
141
 
    my @fnc = ();
142
 
 
143
 
    foreach (split /\n/, $self->{section}->{"New Procedures and Functions"})
144
 
    {
145
 
        push @fnc, $_ unless ($_ eq "" or $_ eq "None");
146
 
 
147
 
        next unless /$eofnc_re/;
148
 
 
149
 
        if (__normalize_proto(@fnc) =~ /$function_re/)
150
 
        {
151
 
            my ($return, $name, $parms) = ($1, $2, $3);
152
 
            if (!__ignore_function($name, $extname))
153
 
            {
154
 
                $name =~ s/^/gl/ unless $name =~ /$prefix_re/;
155
 
                if ($name =~ /^gl/ && $name !~ /^glX/)
156
 
                {
157
 
                    $return =~ s/$types_re/$typemap{$1}/g;
158
 
                    $return =~ s/$voidtype_re/$void_typemap{$1}/g;
159
 
                    $parms  =~ s/$types_re/$typemap{$1}/g;
160
 
                    $parms  =~ s/$voidtype_re/$void_typemap{$1}/g;
161
 
                }
162
 
                $functions{$name} = {
163
 
                    rtype => $return,
164
 
                    parms => $parms,
165
 
                };
166
 
            }
167
 
        }
168
 
        @fnc = ();
169
 
    }
170
 
 
171
 
    return %functions;
172
 
}
173
 
 
174
 
sub __normalize_proto
175
 
{
176
 
    local $_ = join(" ", @_);
177
 
    s/\s+/ /g;                # multiple whitespace -> single space
178
 
    s/\s*\(\s*/ \(/;          # exactly one space before ( and none after
179
 
    s/\s*\)\s*/\)/;           # no after before or after )
180
 
    s/\s*\*([a-zA-Z])/\* $1/; # "* identifier" XXX: g missing?
181
 
    s/\*wgl/\* wgl/;          # "* wgl"        XXX: why doesn't the
182
 
    s/\*glX/\* glX/;          # "* glX"             previous re catch this?
183
 
    s/\.\.\./void/;           # ... -> void
184
 
    s/;$//;                   # remove ; at the end of the line
185
 
    return $_;
186
 
}
187
 
 
188
 
sub __ignore_function
189
 
{
190
 
    return 0;
191
 
}
192
 
 
193
 
sub __compile_regex
194
 
{
195
 
    my $regex = join('', @_);
196
 
    return qr/$regex/
197
 
}
198
 
 
199
 
sub __compile_wordlist_cap
200
 
{
201
 
    __compile_regex('\b(', join('|', @_), ')\b');
202
 
}
 
1
package OpenGL::Spec;
 
2
 
 
3
# A very simple task further complicated by the fact that some people
 
4
# can't read, others use legacy Operating Systems, and others don't give
 
5
# a damn about using a halfway decent text editor.
 
6
#
 
7
# The code to parse the _template_ is so simple and straightforward...
 
8
# yet the code to parse the real spec files is this mess.
 
9
 
 
10
my %typemap = (
 
11
    bitfield    => "GLbitfield",
 
12
    boolean     => "GLboolean",
 
13
    # fsck up in EXT_vertex_array
 
14
    Boolean     => "GLboolean",
 
15
    byte        => "GLbyte",
 
16
    clampd      => "GLclampd",
 
17
    clampf      => "GLclampf",
 
18
    double      => "GLdouble",
 
19
    enum        => "GLenum",
 
20
    # Intel fsck up
 
21
    Glenum      => "GLenum",
 
22
    float       => "GLfloat",
 
23
    half        => "GLuint",
 
24
    int         => "GLint",
 
25
    short       => "GLshort",
 
26
    sizei       => "GLsizei",
 
27
    ubyte       => "GLubyte",
 
28
    uint        => "GLuint",
 
29
    ushort      => "GLushort",
 
30
    DMbuffer    => "void *",
 
31
 
 
32
    # ARB VBO introduces these
 
33
    sizeiptrARB => "GLsizeiptrARB",
 
34
    intptrARB   => "GLintptrARB",
 
35
 
 
36
    # ARB shader objects introduces these, charARB is at least 8 bits,
 
37
    # handleARB is at least 32 bits
 
38
    charARB     => "GLcharARB",
 
39
    handleARB   => "GLhandleARB",
 
40
 
 
41
    # GLX 1.3 defines new types which might not be available at compile time
 
42
    #GLXFBConfig   => "void*",
 
43
    #GLXFBConfigID => "XID",
 
44
    #GLXContextID  => "XID",
 
45
    #GLXWindow     => "XID",
 
46
    #GLXPbuffer    => "XID",
 
47
 
 
48
    # Weird stuff for some SGIX extension
 
49
    #GLXFBConfigSGIX   => "void*",
 
50
    #GLXFBConfigIDSGIX => "XID",
 
51
);
 
52
 
 
53
my %void_typemap = (
 
54
    void    => "GLvoid",
 
55
);
 
56
 
 
57
my $section_re  = qr{^[A-Z]};
 
58
my $function_re = qr{^(.+) ([a-z][a-z0-9_]*) \((.+)\)$}i;
 
59
my $token_re    = qr{^([A-Z0-9][A-Z0-9_]*):?\s+((?:0x)?[0-9A-F]+)(.*)$};
 
60
my $prefix_re   = qr{^(?:AGL | GLX | WGL)_}x;
 
61
my $eofnc_re    = qr{ \);?$ | ^$ }x;
 
62
my $function_re = qr{^(.+) ([a-z][a-z0-9_]*) \((.+)\)$}i;
 
63
my $prefix_re   = qr{^(?:gl | agl | wgl | glX)}x;
 
64
my $types_re    = __compile_wordlist_cap(keys %typemap);
 
65
my $voidtype_re = __compile_wordlist_cap(keys %void_typemap);
 
66
 
 
67
sub new($)
 
68
{
 
69
    my $class = shift;
 
70
    my $self = { section => {} };
 
71
    $self->{filename} = shift;
 
72
    local $/;
 
73
    open(my $fh, "<$self->{filename}") or die "Can't open $self->{filename}";
 
74
    my $content = <$fh>;
 
75
    my $section;
 
76
    my $s = $self->{section};
 
77
 
 
78
    $content =~ s{[ \t]+$}{}mg;
 
79
    # Join lines that end with a word-character and ones that *begin*
 
80
    # with one
 
81
    $content =~ s{(\w)\n(\w)}{$1 $2}sg;
 
82
 
 
83
    foreach (split /\n/, $content)
 
84
    {
 
85
        if (/$section_re/)
 
86
        {
 
87
            chomp;
 
88
            s/^Name String$/Name Strings/; # Fix common mistake
 
89
            $section = $_;
 
90
            $s->{$section} = "";
 
91
        }
 
92
        elsif (defined $section and exists $s->{$section})
 
93
        {
 
94
            s{^\s+}{}mg; # Remove leading whitespace
 
95
            $s->{$section} .= $_ . "\n";
 
96
        }
 
97
    }
 
98
 
 
99
    $s->{$_} =~ s{(?:^\n+|\n+$)}{}s foreach keys %$s;
 
100
 
 
101
    bless $self, $class;
 
102
}
 
103
 
 
104
sub sections()
 
105
{
 
106
    my $self = shift;
 
107
    keys %{$self->{section}};
 
108
}
 
109
 
 
110
sub name()
 
111
{
 
112
    my $self = shift;
 
113
    $self->{section}->{Name};
 
114
}
 
115
 
 
116
sub name_strings()
 
117
{
 
118
    my $self = shift;
 
119
    split("\n", $self->{section}->{"Name Strings"});
 
120
}
 
121
 
 
122
sub tokens()
 
123
{
 
124
    my $self = shift;
 
125
    my %tokens = ();
 
126
    foreach (split /\n/, $self->{section}->{"New Tokens"})
 
127
    {
 
128
        next unless /$token_re/;
 
129
        my ($name, $value) = ($1, $2);
 
130
        $name =~ s{^}{GL_} unless $name =~ /$prefix_re/;
 
131
        $tokens{$name} = $value;
 
132
    }
 
133
 
 
134
    return %tokens;
 
135
}
 
136
 
 
137
sub functions()
 
138
{
 
139
    my $self = shift;
 
140
    my %functions = ();
 
141
    my @fnc = ();
 
142
 
 
143
    foreach (split /\n/, $self->{section}->{"New Procedures and Functions"})
 
144
    {
 
145
        push @fnc, $_ unless ($_ eq "" or $_ eq "None");
 
146
 
 
147
        next unless /$eofnc_re/;
 
148
 
 
149
        if (__normalize_proto(@fnc) =~ /$function_re/)
 
150
        {
 
151
            my ($return, $name, $parms) = ($1, $2, $3);
 
152
            if (!__ignore_function($name, $extname))
 
153
            {
 
154
                $name =~ s/^/gl/ unless $name =~ /$prefix_re/;
 
155
                if ($name =~ /^gl/ && $name !~ /^glX/)
 
156
                {
 
157
                    $return =~ s/$types_re/$typemap{$1}/g;
 
158
                    $return =~ s/$voidtype_re/$void_typemap{$1}/g;
 
159
                    $parms  =~ s/$types_re/$typemap{$1}/g;
 
160
                    $parms  =~ s/$voidtype_re/$void_typemap{$1}/g;
 
161
                }
 
162
                $functions{$name} = {
 
163
                    rtype => $return,
 
164
                    parms => $parms,
 
165
                };
 
166
            }
 
167
        }
 
168
        @fnc = ();
 
169
    }
 
170
 
 
171
    return %functions;
 
172
}
 
173
 
 
174
sub __normalize_proto
 
175
{
 
176
    local $_ = join(" ", @_);
 
177
    s/\s+/ /g;                # multiple whitespace -> single space
 
178
    s/\s*\(\s*/ \(/;          # exactly one space before ( and none after
 
179
    s/\s*\)\s*/\)/;           # no after before or after )
 
180
    s/\s*\*([a-zA-Z])/\* $1/; # "* identifier" XXX: g missing?
 
181
    s/\*wgl/\* wgl/;          # "* wgl"        XXX: why doesn't the
 
182
    s/\*glX/\* glX/;          # "* glX"             previous re catch this?
 
183
    s/\.\.\./void/;           # ... -> void
 
184
    s/;$//;                   # remove ; at the end of the line
 
185
    return $_;
 
186
}
 
187
 
 
188
sub __ignore_function
 
189
{
 
190
    return 0;
 
191
}
 
192
 
 
193
sub __compile_regex
 
194
{
 
195
    my $regex = join('', @_);
 
196
    return qr/$regex/
 
197
}
 
198
 
 
199
sub __compile_wordlist_cap
 
200
{
 
201
    __compile_regex('\b(', join('|', @_), ')\b');
 
202
}