]> git.saurik.com Git - wxWidgets.git/blob - distrib/msw/tmake/lib/wxFileInfo.pm
Temporary ugly trick to make release for OpenWatcom possible.
[wxWidgets.git] / distrib / msw / tmake / lib / wxFileInfo.pm
1 package wxFileInfo;
2
3 =head1 NAME
4
5 wxFileInfo
6
7 =head1 SYNOPSIS
8
9 use wxFileInfo;
10
11 my $info = new wxFileInfo( $filename, $filetype, $fileflags );
12 my $info2 = new wxFileInfo( 'mdig.cpp', 'Generic',
13 'NotWin32,NotGTK,NotMac' );
14
15 $f = $info->filename;
16 $t = $info->filetype;
17 $flags = $info->fileflags;
18 $bool = $info->is_header;
19 $bool = $info->is_source;
20 $file = $info->object_file;
21 $file = $info->source_file;
22 $bool = $info->has_flag( 'NotX' );
23
24 =cut
25
26 use strict;
27
28 sub new {
29 my $ref = shift;
30 my $class = ref( $ref ) || $ref;
31 my $self = bless {}, $class;
32
33 my( $filename, $filetype, $fileflags ) = @_;
34 $fileflags =~ tr/ \t//d;
35
36 @{$self}{'filename', 'filetype'} = ( $filename, $filetype );
37 $self->{fileflags} = [ split /,/, $fileflags ];
38
39 return $self;
40 }
41
42 sub filename { $_[0]->{filename} }
43 sub filetype { $_[0]->{filetype} }
44 sub fileflags { $_[0]->{fileflags} }
45 sub is_header { scalar( $_[0]->{filename} =~ m/\.h$/i ) }
46 sub is_source { !scalar( $_[0]->{filename} =~ m/\.h$/i ) }
47
48 sub object_file {
49 my $self = shift;
50 my $obj = $self->{filename};
51
52 $obj =~ s/cp?p?$/o/i; # PORTABILITY
53
54 return $obj;
55 }
56
57 my %src_prefix = ( Common => 'common/',
58 Generic => 'generic/',
59 MSW => 'msw/',
60 Mac => 'mac/',
61 Motif => 'motif/',
62 GTK => 'gtk/',
63 Univ => 'univ/',
64 X11 => 'x11/',
65 HTML => 'html/',
66 Unix => 'unix/',
67 WXH => '',
68 ProtoH => 'protocol/',
69 HtmlH => 'html/',
70 MotifH => 'motif/',
71 X11H => 'x11/',
72 GenericH => 'generic/',
73 UnixH => 'unix/',
74 );
75
76 sub source_file {
77 my $self = shift;
78 my $type = $self->filetype;
79
80 die "Unknown file type '$type'" unless exists $src_prefix{$type};
81 return $src_prefix{$type} . $self->filename; # PORTABILITY
82 }
83
84 sub has_flag {
85 my( $self, $flag ) = @_;
86 $flag = lc( $flag );
87 return grep { lc( $_ ) eq $flag } @{$self->{fileflags}};
88 }
89
90 1;