"Fossies" - the Fresh Open Source Software Archive

Member "MIME-Types-2.17/lib/MIME/Types.pm" (26 Jan 2018, 7043 Bytes) of package /linux/privat/MIME-Types-2.17.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Types.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 2.16_vs_2.17.

    1 # Copyrights 1999-2018 by [Mark Overmeer <markov@cpan.org>].
    2 #  For other contributors see ChangeLog.
    3 # See the manual pages for details on the licensing terms.
    4 # Pod stripped from pm file by OODoc 2.02.
    5 # This code is part of distribution MIME::Types.  Meta-POD processed with
    6 # OODoc into POD and HTML manual-pages.  See README.md
    7 # Copyright Mark Overmeer.  Licensed under the same terms as Perl itself.
    8 
    9 package MIME::Types;
   10 use vars '$VERSION';
   11 $VERSION = '2.17';
   12 
   13 
   14 use strict;
   15 
   16 use MIME::Type     ();
   17 use File::Spec     ();
   18 use File::Basename qw(dirname);
   19 use List::Util     qw(first);
   20 
   21 
   22 my %typedb;
   23 sub new(@) { (bless {}, shift)->init( {@_} ) }
   24 
   25 sub init($)
   26 {   my ($self, $args) = @_;
   27     keys %typedb or $self->_read_db($args);
   28     $self;
   29 }
   30 
   31 sub _read_db($)
   32 {   my ($self, $args)   = @_;
   33     my $skip_extensions = $args->{skip_extensions};
   34     my $only_complete   = $args->{only_complete};
   35     my $only_iana       = $args->{only_iana};
   36 
   37     my $db              = $ENV{PERL_MIME_TYPE_DB}
   38       || $args->{db_file}
   39       || File::Spec->catfile(dirname(__FILE__), 'types.db');
   40 
   41     local *DB;
   42     open DB, '<:encoding(utf8)', $db
   43        or die "cannot open type database in $db: $!\n";
   44 
   45     while(1)
   46     {   my $header = <DB>;
   47         defined $header or last;
   48         chomp $header;
   49 
   50         # This logic is entangled with the bin/collect_types script
   51         my ($count, $major, $is_iana, $has_ext) = split /\:/, $header;
   52         my $skip_section = $major eq 'EXTENSIONS' ? $skip_extensions
   53           : (($only_iana && !$is_iana) || ($only_complete && !$has_ext));
   54 
   55 #warn "Skipping section $header\n" if $skip_section;
   56         (my $section = $major) =~ s/^x-//;
   57         if($major eq 'EXTENSIONS')
   58         {   local $_;
   59             while(<DB>)
   60             {   last if m/^$/;
   61                 next if $skip_section;
   62                 chomp;
   63                 $typedb{$section}{$1} = $2 if m/(.*);(.*)/;
   64             }
   65         }
   66         else
   67         {   local $_;
   68             while(<DB>)
   69             {   last if m/^$/;
   70                 next if $skip_section;
   71                 chomp;
   72                 $typedb{$section}{$1} = "$major/$_" if m/^(?:x-)?([^;]+)/;
   73             }
   74         }
   75     }
   76 
   77     close DB;
   78 }
   79 
   80 # Catalyst-Plugin-Static-Simple uses it :(
   81 sub create_type_index {}
   82 
   83 #-------------------------------------------
   84 
   85 sub type($)
   86 {   my $spec    = lc $_[1];
   87     $spec       = 'text/plain' if $spec eq 'text';   # old mailers
   88 
   89     $spec =~ m!^(?:x\-)?([^/]+)/(?:x-)?(.*)!
   90         or return;
   91 
   92     my $section = $typedb{$1}    or return;
   93     my $record  = $section->{$2} or return;
   94     return $record if ref $record;   # already extended
   95 
   96     my $simple   = $2;
   97     my ($type, $ext, $enc) = split m/\;/, $record;
   98     my $os       = undef;   # XXX TODO
   99 
  100     $section->{$simple} = MIME::Type->new
  101       ( type       => $type
  102       , extensions => [split /\,/, $ext]
  103       , encoding   => $enc
  104       , system     => $os
  105       );
  106 }
  107 
  108 
  109 sub mimeTypeOf($)
  110 {   my ($self, $name) = @_;
  111     (my $ext = lc $name) =~ s/.*\.//;
  112     my $type = $typedb{EXTENSIONS}{$ext} or return;
  113     $self->type($type);
  114 }
  115 
  116 
  117 sub addType(@)
  118 {   my $self = shift;
  119 
  120     foreach my $type (@_)
  121     {   my ($major, $minor) = split m!/!, $type->simplified;
  122         $typedb{$major}{$minor} = $type;
  123         $typedb{EXTENSIONS}{$_} = $type for $type->extensions;
  124     }
  125     $self;
  126 }
  127 
  128 
  129 sub types()
  130 {   my $self  = shift;
  131     my @types;
  132     foreach my $section (keys %typedb)
  133     {   next if $section eq 'EXTENSIONS';
  134         push @types, map $_->type("$section/$_"),
  135                          sort keys %{$typedb{$section}};
  136     }
  137     @types;
  138 }
  139 
  140 
  141 sub listTypes()
  142 {   my $self  = shift;
  143     my @types;
  144     foreach my $section (keys %typedb)
  145     {   next if $section eq 'EXTENSIONS';
  146         foreach my $sub (sort keys %{$typedb{$section}})
  147         {   my $record = $typedb{$section}{$sub};
  148             push @types, ref $record            ? $record->type
  149                        : $record =~ m/^([^;]+)/ ? $1 : die;
  150         }
  151     }
  152     @types;
  153 }
  154 
  155 
  156 sub extensions { keys %{$typedb{EXTENSIONS}} }
  157 sub _MojoExtTable() {$typedb{EXTENSIONS}}
  158 
  159 #-------------
  160 
  161 sub httpAccept($)
  162 {   my $self   = shift;
  163     my @listed;
  164 
  165     foreach (split /\,\s*/, shift)
  166     {
  167         m!^   ([a-zA-Z0-9-]+ | \*) / ( [a-zA-Z0-9+-]+ | \* )
  168           \s* (?: \;\s*q\=\s* ([0-9]+(?:\.[0-9]*)?) \s* )?
  169               (\;.* | )
  170           $ !x or next;
  171 
  172         my $mime = "$1/$2$4";
  173         my $q    = defined $3 ? $3 : 1;   # q, default=1
  174 
  175         # most complex first
  176         $q += $4 ? +0.01 : $1 eq '*' ? -0.02 : $2 eq '*' ? -0.01 : 0;
  177 
  178         # keep order
  179         $q -= @listed*0.0001;
  180 
  181         push @listed, [ $mime => $q ];
  182     }
  183     map $_->[0], sort {$b->[1] <=> $a->[1]} @listed;
  184 }
  185 
  186 
  187 sub httpAcceptBest($@)
  188 {   my $self   = shift;
  189     my @accept = ref $_[0] eq 'ARRAY' ? @{(shift)} : $self->httpAccept(shift);
  190     my $match;
  191 
  192     foreach my $acc (@accept)
  193     {   $acc   =~ s/\s*\;.*//;    # remove attributes
  194         my $m = $acc !~ s#/\*$## ? first { $_->equals($acc) } @_
  195               : $acc eq '*'      ? $_[0]     # $acc eq */*
  196               :                    first { $_->mediaType eq $acc } @_;
  197         return $m if defined $m;
  198     }
  199 
  200     ();
  201 }
  202 
  203 
  204 sub httpAcceptSelect($@)
  205 {   my ($self, $accept) = (shift, shift);
  206     my $fns  = !@_ ? return () : ref $_[0] eq 'ARRAY' ? shift : [@_];
  207 
  208     unless(defined $accept)
  209     {   my $fn = $fns->[0];
  210         return ($fn, $self->mimeTypeOf($fn));
  211     }
  212 
  213     # create mapping  type -> filename
  214     my (%have, @have);
  215     foreach my $fn (@$fns)
  216     {   my $type = $self->mimeTypeOf($fn) or next;
  217         $have{$type->simplified} = $fn;
  218         push @have, $type;
  219     }
  220 
  221     my $type = $self->httpAcceptBest($accept, @have);
  222     defined $type ? ($have{$type}, $type) : ();
  223 }
  224 
  225 #-------------------------------------------
  226 # OLD INTERFACE (version 0.06 and lower)
  227 
  228 
  229 use base 'Exporter';
  230 our @EXPORT_OK = qw(by_suffix by_mediatype import_mime_types);
  231 
  232 
  233 my $mime_types;
  234 
  235 sub by_suffix($)
  236 {   my $filename = shift;
  237     $mime_types ||= MIME::Types->new;
  238     my $mime     = $mime_types->mimeTypeOf($filename);
  239 
  240     my @data     = defined $mime ? ($mime->type, $mime->encoding) : ('','');
  241     wantarray ? @data : \@data;
  242 }
  243 
  244 
  245 sub by_mediatype($)
  246 {   my $type = shift;
  247     $mime_types ||= MIME::Types->new;
  248 
  249     my @found;
  250     if(!ref $type && index($type, '/') >= 0)
  251     {   my $mime   = $mime_types->type($type);
  252         @found     = $mime if $mime;
  253     }
  254     else
  255     {   my $search = ref $type eq 'Regexp' ? $type : qr/$type/i;
  256         @found     = map $mime_types->type($_),
  257                          grep $_ =~ $search,
  258                              $mime_types->listTypes;
  259     }
  260 
  261     my @data;
  262     foreach my $mime (@found)
  263     {   push @data, map [$_, $mime->type, $mime->encoding],
  264                         $mime->extensions;
  265     }
  266 
  267     wantarray ? @data : \@data;
  268 }
  269 
  270 
  271 sub import_mime_types($)
  272 {   my $filename = shift;
  273     use Carp;
  274     croak <<'CROAK';
  275 import_mime_types is not supported anymore: if you have types to add
  276 please send them to the author.
  277 CROAK
  278 }
  279 
  280 1;