← Back to branch summary

~ubuntu-branches/ubuntu/saucy/padre/saucy-proposed

« back to all changes in this revision

Viewing changes to lib/Padre/Wx/Theme.pm

  • Committer: Package Import Robot
  • Author(s): Dominique Dumont, gregor herrmann, Dominique Dumont
  • Date: 2012-01-04 12:04:20 UTC
  • mfrom: (1.3.3)
  • Revision ID: package-import@ubuntu.com-20120104120420-i5oybqwf91m1d3il
Tags: 0.92.ds1-1
[ gregor herrmann ]
* Remove debian/source/local-options; abort-on-upstream-changes
  and unapply-patches are default in dpkg-source since 1.16.1.
* Swap order of alternative (build) dependencies after the perl
  5.14 transition.

[ Dominique Dumont ]
* Imported Upstream version 0.92.ds1
* removed fix-spelling patch (applied upstream)
* lintian-override: use wildcard to avoid listing a gazillion files
* updated size of some 'not-real-man-page' entries
* rules: remove dekstop cruft (replaced by a file provided in debian
  directory)
* control: removed Breaks statement. Add /me to uploaders. Updated
  dependencies
* rules: make sure that non-DFSG file (i.e. the cute butterfly, sigh)
  is not distributed

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/Padre/Wx/Theme.pm
 
1
package Padre::Wx::Theme;
 
2
 
 
3
use 5.008;
 
4
use strict;
 
5
use warnings;
 
6
use File::Spec       ();
 
7
use IO::File         ();
 
8
use Scalar::Util     ();
 
9
use Params::Util     ();
 
10
use Padre::Constant  ();
 
11
use Padre::Util      ();
 
12
use Padre::Wx        ();
 
13
use Padre::Wx::Style ();
 
14
use Wx::Scintilla    ();
 
15
 
 
16
our $VERSION = '0.92';
 
17
 
 
18
# Locate the directories containing styles
 
19
use constant {
 
20
        CORE_DIRECTORY => Padre::Util::sharedir('themes'),
 
21
        USER_DIRECTORY => File::Spec->catdir(
 
22
                Padre::Constant::CONFIG_DIR,
 
23
                'themes',
 
24
        ),
 
25
};
 
26
 
 
27
 
 
28
 
 
29
 
 
30
 
 
31
######################################################################
 
32
# Configuration
 
33
 
 
34
# Commands allowed in the style
 
35
my %PARAM = (
 
36
        name                    => [ 2, 'name' ],
 
37
        gui                     => [ 1, 'class' ],
 
38
        style                   => [ 1, 'mime' ],
 
39
        include                 => [ 1, 'mime' ],
 
40
        SetForegroundColour     => [ 1, 'color' ],
 
41
        SetBackgroundColour     => [ 1, 'color' ],
 
42
        SetCaretLineBackground  => [ 1, 'color' ],
 
43
        SetCaretForeground      => [ 1, 'color' ],
 
44
        CallTipSetBackground    => [ 1, 'color' ],
 
45
        SetWhitespaceBackground => [ 2, 'boolean,color' ],
 
46
        SetWhitespaceForeground => [ 2, 'boolean,color' ],
 
47
        SetSelBackground        => [ 2, 'style,color' ],
 
48
        SetSelForeground        => [ 1, 'style,color' ],
 
49
        StyleAllBackground      => [ 1, 'color' ],
 
50
        StyleAllForeground      => [ 1, 'color' ],
 
51
        StyleSetBackground      => [ 2, 'style,color' ],
 
52
        StyleSetForeground      => [ 2, 'style,color' ],
 
53
        StyleSetBold            => [ 2, 'style,boolean' ],
 
54
        StyleSetItalic          => [ 2, 'style,boolean' ],
 
55
        StyleSetEOLFilled       => [ 2, 'style,boolean' ],
 
56
        StyleSetUnderline       => [ 2, 'style,boolean' ],
 
57
        StyleSetSpec            => [ 2, 'style,spec' ],
 
58
        SetFoldMarginColour     => [ 2, 'boolean,color' ],
 
59
        SetFoldMarginHiColour   => [ 2, 'boolean,color' ],
 
60
        MarkerSetForeground     => [ 2, 'style,color' ],
 
61
        MarkerSetBackground     => [ 2, 'style,color' ],
 
62
);
 
63
 
 
64
# Fallback path of next best styles if no style exists.
 
65
# The fallback of last resort is automatically to text/plain
 
66
my %FALLBACK = (
 
67
        'application/x-psgi'     => 'application/x-perl',
 
68
        'application/x-php'      => 'application/perl',      # Temporary solution
 
69
        'application/json'       => 'application/javascript',
 
70
        'application/javascript' => 'text/x-c',
 
71
        'text/x-java-source'     => 'text/x-c',
 
72
        'text/x-c++src'          => 'text/x-c',
 
73
        'text/x-csharp'          => 'text/x-c',
 
74
);
 
75
 
 
76
 
 
77
 
 
78
 
 
79
 
 
80
######################################################################
 
81
# Style Repository
 
82
 
 
83
sub files {
 
84
        my $class  = shift;
 
85
        my %styles = ();
 
86
 
 
87
        # Scan style directories
 
88
        foreach my $directory ( USER_DIRECTORY, CORE_DIRECTORY ) {
 
89
                next unless -d $directory;
 
90
 
 
91
                # Search the directory
 
92
                local *STYLEDIR;
 
93
                unless ( opendir( STYLEDIR, $directory ) ) {
 
94
                        die "Failed to read '$directory'";
 
95
                }
 
96
                foreach my $file ( readdir STYLEDIR ) {
 
97
                        next unless $file =~ s/\.txt\z//;
 
98
                        next unless Params::Util::_IDENTIFIER($file);
 
99
                        next if $styles{$file};
 
100
                        $styles{$file} = File::Spec->catfile(
 
101
                                $directory,
 
102
                                "$file.txt"
 
103
                        );
 
104
                }
 
105
                closedir STYLEDIR;
 
106
        }
 
107
 
 
108
        return \%styles;
 
109
}
 
110
 
 
111
# Get the file name for a named style
 
112
sub file {
 
113
        my $class = shift;
 
114
        my $name  = shift;
 
115
        foreach my $directory ( USER_DIRECTORY, CORE_DIRECTORY ) {
 
116
                my $file = File::Spec->catfile(
 
117
                        $directory,
 
118
                        "$name.txt",
 
119
                );
 
120
                return $file if -f $file;
 
121
        }
 
122
        return undef;
 
123
}
 
124
 
 
125
sub labels {
 
126
        my $class  = shift;
 
127
        my $locale = shift;
 
128
        my $files  = $class->files;
 
129
 
 
130
        # Load the label for each file.
 
131
        # Because we resolve the filename again this is slower than
 
132
        # it could be, but the code is simple and easy and will do for now.
 
133
        my %labels = ();
 
134
        foreach my $name ( keys %$files ) {
 
135
                $labels{$name} = $class->label( $name, $locale );
 
136
        }
 
137
 
 
138
        return \%labels;
 
139
}
 
140
 
 
141
sub label {
 
142
        my $class  = shift;
 
143
        my $name   = shift;
 
144
        my $locale = shift;
 
145
        my $file   = $class->file($name);
 
146
        unless ($file) {
 
147
                die "The style '$name' does not exist";
 
148
        }
 
149
 
 
150
        # Parse the file for name statements
 
151
        my $line   = 0;
 
152
        my %label  = ();
 
153
        my $handle = IO::File->new( $file, 'r' ) or return;
 
154
        while ( defined( my $string = <$handle> ) ) {
 
155
                $line++;
 
156
 
 
157
                # Clean the line
 
158
                $string =~ s/^\s*//s;
 
159
                $string =~ s/\s*\z//s;
 
160
 
 
161
                # Skip blanks and comments
 
162
                next unless $string =~ /^\s*[^#]/;
 
163
 
 
164
                # Split the line into a command and params
 
165
                my @list = split /\s+/, $string;
 
166
                my $cmd = shift @list;
 
167
 
 
168
                # We only care about name
 
169
                next unless defined $cmd;
 
170
                last unless $cmd eq 'name';
 
171
 
 
172
                # Save the name
 
173
                my $lang = shift @list;
 
174
                $label{$lang} = join ' ', @list;
 
175
        }
 
176
        $handle->close;
 
177
 
 
178
        # Try to find a usable label
 
179
        return $label{$locale} || $label{'en-gb'} || $name;
 
180
}
 
181
 
 
182
sub options {
 
183
        $_[0]->labels('en-gb');
 
184
}
 
185
 
 
186
sub find {
 
187
        my $class = shift;
 
188
        my $name  = shift;
 
189
        my $file  = $class->file($name);
 
190
        unless ($file) {
 
191
                die "The style '$name' does not exist";
 
192
        }
 
193
        return $class->load($file);
 
194
}
 
195
 
 
196
 
 
197
 
 
198
 
 
199
 
 
200
######################################################################
 
201
# Constructor and Accessors
 
202
 
 
203
sub new {
 
204
        my $class = shift;
 
205
        my $self = bless { @_, code => {} }, $class;
 
206
        unless ( defined $self->name ) {
 
207
                die "No default en-gb name for style";
 
208
        }
 
209
        unless ( defined $self->mime ) {
 
210
                die "No default text/plain style";
 
211
        }
 
212
 
 
213
        return $self;
 
214
}
 
215
 
 
216
sub load {
 
217
        my $class = shift;
 
218
        my $file  = shift;
 
219
        unless ( -f $file ) {
 
220
                die "Missing or invalid style file '$file'";
 
221
        }
 
222
 
 
223
        # Open the file
 
224
        my $handle = IO::File->new( $file, 'r' ) or return;
 
225
        my $self = $class->parse($handle);
 
226
        $handle->close;
 
227
 
 
228
        return $self;
 
229
}
 
230
 
 
231
sub name {
 
232
        my $self = shift;
 
233
        my $lang = shift || 'en-gb';
 
234
        return $self->{name}->{$lang};
 
235
}
 
236
 
 
237
sub mime {
 
238
        my $self = shift;
 
239
        my $mime = shift || 'text/plain';
 
240
        while ( not $self->{mime}->{$mime} ) {
 
241
                if ( $mime eq 'text/plain' ) {
 
242
 
 
243
                        # A null seqeunce... I guess...
 
244
                        return [];
 
245
                } else {
 
246
                        $mime = $FALLBACK{$mime} || 'text/plain';
 
247
                }
 
248
        }
 
249
        return $self->{mime}->{$mime};
 
250
}
 
251
 
 
252
 
 
253
 
 
254
 
 
255
 
 
256
######################################################################
 
257
# Style Parser
 
258
 
 
259
sub parse {
 
260
        my $class = shift;
 
261
        my $handle = Params::Util::_HANDLE(shift) or die "Not a file handle";
 
262
 
 
263
        # Load the delayed modules
 
264
        require Padre::Wx;
 
265
        require Padre::Locale;
 
266
 
 
267
        # Parse the file
 
268
        my %name   = ();
 
269
        my %styles = ();
 
270
        my $style  = undef;
 
271
        my $line   = 0;
 
272
        while ( defined( my $string = <$handle> ) ) {
 
273
                $line++;
 
274
 
 
275
                # Clean the line
 
276
                $string =~ s/^\s*//s;
 
277
                $string =~ s/\s*\z//s;
 
278
 
 
279
                # Skip blanks and comments
 
280
                next unless $string =~ /^\s*[^#]/;
 
281
 
 
282
                # Split the line into a command and params
 
283
                my @list = split /\s+/, $string;
 
284
                my $cmd = shift @list;
 
285
                unless ( defined $PARAM{$cmd} ) {
 
286
                        die "Line $line: Unsupported style command '$string'";
 
287
                }
 
288
                unless ( @list >= $PARAM{$cmd}->[0] ) {
 
289
                        die "Line $line: Insufficient parameters in command '$string'";
 
290
                }
 
291
 
 
292
                # Handle special commands
 
293
                if ( $cmd eq 'name' ) {
 
294
 
 
295
                        # Does the language exist
 
296
                        my $lang = shift @list;
 
297
                        unless ( Padre::Locale::rfc4646_exists($lang) ) {
 
298
                                die "Line $line: Unknown language in command '$string'";
 
299
                        }
 
300
 
 
301
                        # Save the name
 
302
                        $name{$lang} = join ' ', @list;
 
303
 
 
304
                } elsif ( $cmd eq 'style' or $cmd eq 'gui' ) {
 
305
 
 
306
                        # Switch to the new mime type
 
307
                        $style = $styles{ $list[0] } = Padre::Wx::Style->new;
 
308
 
 
309
                } elsif ( $cmd eq 'include' ) {
 
310
 
 
311
                        # Copy another style as a starting point
 
312
                        my $copy = $styles{ $list[0] };
 
313
                        unless ($copy) {
 
314
                                die "Line $line: Style '$list[0]' is not defined (yet)";
 
315
                        }
 
316
                        $style->include($copy);
 
317
 
 
318
                } elsif ( $PARAM{$cmd}->[1] eq 'color' ) {
 
319
 
 
320
                        # General commands that are passed a single colour
 
321
                        my $color = Padre::Wx::color( shift @list );
 
322
                        $style->add( $cmd => [ $color ] );
 
323
 
 
324
                } elsif ( $PARAM{$cmd}->[1] eq 'style,color' ) {
 
325
 
 
326
                        # Style specific commands that are passed a single color
 
327
                        my $id = $class->parse_style( $line, shift @list );
 
328
                        my $color = Padre::Wx::color( shift @list );
 
329
                        $style->add( $cmd => [ $id, $color ] );
 
330
 
 
331
                } elsif ( $PARAM{$cmd}->[1] eq 'style,boolean' ) {
 
332
 
 
333
                        # Style specific commands that are passed a boolean value
 
334
                        my $id = $class->parse_style( $line, shift @list );
 
335
                        my $boolean = $class->parse_boolean( $line, shift @list );
 
336
                        $style->add( $cmd => [ $id, $boolean ] );
 
337
 
 
338
                } elsif ( $PARAM{$cmd}->[1] eq 'style,spec' ) {
 
339
 
 
340
                        # Style command that is passed a spec string
 
341
                        my $style = $class->parse_style( $line, shift @list );
 
342
                        my $spec = shift @list;
 
343
 
 
344
                } elsif ( $PARAM{$cmd}->[1] eq 'boolean,color' ) {
 
345
                        my $boolean = $class->parse_boolean( $line, shift @list );
 
346
                        my $color = Padre::Wx::color( shift @list );
 
347
                        $style->add( $cmd => [ $boolean, $color ] );
 
348
 
 
349
                } else {
 
350
                        die "Line $line: Unsupported style command '$string'";
 
351
                }
 
352
        }
 
353
 
 
354
        return $class->new(
 
355
                name => \%name,
 
356
                mime => \%styles,
 
357
        );
 
358
}
 
359
 
 
360
sub parse_style {
 
361
        my $class  = shift;
 
362
        my $line   = shift;
 
363
        my $string = shift;
 
364
        my $copy   = $string;
 
365
        if ( defined Params::Util::_NONNEGINT($string) ) {
 
366
                return $string;
 
367
        } elsif ( $string =~ /^PADRE_\w+\z/ ) {
 
368
                unless ( Padre::Constant->can($string) ) {
 
369
                        die "Line $line: Unknown or unsupported style '$copy'";
 
370
                }
 
371
                $string = "Padre::Constant::$string";
 
372
        } elsif ( $string =~ /^\w+\z/ ) {
 
373
                unless ( Wx::Scintilla->can($string) ) {
 
374
                        die "Line $line: Unknown or unsupported style '$copy'";
 
375
                }
 
376
                $string = "Wx::Scintilla::$string";
 
377
        } else {
 
378
                die "Line $line: Unknown or unsupported style '$copy'";
 
379
        }
 
380
 
 
381
        # Capture the numeric form of the constant
 
382
        no strict 'refs';
 
383
        $string = eval { $string->() };
 
384
        if ($@) {
 
385
                die "Line $line: Unknown or unsupported style '$copy'";
 
386
        }
 
387
 
 
388
        return $string;
 
389
}
 
390
 
 
391
sub parse_boolean {
 
392
        my $class  = shift;
 
393
        my $line   = shift;
 
394
        my $string = shift;
 
395
        unless ( $string eq '0' or $string eq '1' ) {
 
396
                die "Line $line: Boolean value '$string' is not 0 or 1";
 
397
        }
 
398
        return $string;
 
399
}
 
400
 
 
401
 
 
402
 
 
403
 
 
404
 
 
405
######################################################################
 
406
# Compilation and Application
 
407
 
 
408
sub apply {
 
409
        my $self   = shift;
 
410
        my $object = shift;
 
411
 
 
412
        # Clear any previous style
 
413
        $self->clear($object);
 
414
 
 
415
        if ( Params::Util::_INSTANCE( $object, 'Padre::Wx::Editor' ) ) {
 
416
                # This is an editor style
 
417
                my $document = $object->{Document} or return;
 
418
                my $mimetype = $document->mimetype or return;
 
419
                $self->mime($mimetype)->apply($object);
 
420
 
 
421
        } else {
 
422
                # This is a GUI style, chase the inheritance tree.
 
423
                # Uses inlined Class::ISA algorithm as in Class::Inspector
 
424
                my $class = Scalar::Util::blessed($object);
 
425
                my @queue = ( $class );
 
426
                my %seen  = ( $class => 1 );
 
427
                while ( my $package = shift @queue ) {
 
428
                        no strict 'refs';
 
429
                        unshift @queue, grep { ! $seen{$_}++ }
 
430
                                map { s/^::/main::/; s/\'/::/g; $_ }
 
431
                                ( @{"${package}::ISA"} );
 
432
 
 
433
                        # Apply the first style that patches
 
434
                        my $style = $self->{mime}->{$package} or next;
 
435
                        $style->apply($object);
 
436
                        return 1;
 
437
                }
 
438
        }
 
439
 
 
440
        return 1;
 
441
}
 
442
 
 
443
sub clear {
 
444
        my $self   = shift;
 
445
        my $object = shift;
 
446
 
 
447
        if ( Params::Util::_INSTANCE( $object, 'Padre::Wx::Editor' ) ) {
 
448
 
 
449
                # Clears settings back to the editor configuration defaults
 
450
                # To do this we flush absolutely everything and then apply
 
451
                # the basic font settings.
 
452
                $object->StyleResetDefault;
 
453
 
 
454
                # Reset the font from configuration (which Scintilla considers part of
 
455
                # the "style" but Padre doesn't allow to be changed as a "style")
 
456
                require Padre::Wx;
 
457
                my $config = $object->config;
 
458
                my $font   = Padre::Wx::editor_font( $config->editor_font );
 
459
                $object->SetFont($font);
 
460
                $object->StyleSetFont( Wx::Scintilla::STYLE_DEFAULT, $font );
 
461
 
 
462
                # Clear all styles back to the default
 
463
                $object->StyleClearAll;
 
464
 
 
465
        } else {
 
466
                # Reset the GUI element colours back to defaults
 
467
                ### Disabled as it blacks the directory tree for some reason
 
468
                # $object->SetForegroundColour( Wx::NullColour );
 
469
                # $object->SetBackgroundColour( Wx::NullColour );
 
470
        }
 
471
 
 
472
        return 1;
 
473
}
 
474
 
 
475
1;
 
476
 
 
477
# Copyright 2008-2011 The Padre development team as listed in Padre.pm.
 
478
# LICENSE
 
479
# This program is free software; you can redistribute it and/or
 
480
# modify it under the same terms as Perl 5 itself.