home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Cap.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-22  |  8.7 KB  |  385 lines
  1.  
  2. package Mail::Cap;
  3. use strict;
  4.  
  5. use vars qw($VERSION $useCache);
  6.  
  7. $VERSION = "1.60";
  8. sub Version { $VERSION; }
  9.  
  10. =head1 NAME
  11.  
  12. Mail::Cap - Parse mailcap files
  13.  
  14. =head1 SYNOPSIS
  15.  
  16.     my $mc = new Mail::Cap;
  17.  
  18.     $desc = $mc->description('image/gif');
  19.  
  20.     print "GIF desc: $desc\n";
  21.  
  22.     $cmd = $mc->viewCmd('text/plain; charset=iso-8859-1', 'file.txt');
  23.  
  24. =head1 DESCRIPTION
  25.  
  26. Parse mailcap files as specified in RFC 1524 - I<A User Agent
  27. Configuration Mechanism For Multimedia Mail Format Information>.  In
  28. the description below C<$type> refers to the MIME type as specified in
  29. the I<Content-Type> header of mail or HTTP messages.  Examples of
  30. types are:
  31.  
  32.   image/gif
  33.   text/html
  34.   text/plain; charset=iso-8859-1
  35.  
  36. =cut
  37.  
  38. $useCache = 1;  # don't evaluate tests every time
  39.  
  40. my @path;
  41.  
  42. if($^O eq "MacOS") {
  43.     @path = split(/,/, $ENV{MAILCAPS} ||
  44.     "$ENV{HOME}mailcap");
  45. } else {
  46.     @path = split(/:/, $ENV{MAILCAPS} ||
  47.     # this path is specified under RFC 1524 appendix A 
  48.     ( defined($ENV{HOME})
  49.       ? "$ENV{HOME}/.mailcap:/etc/mailcap:/usr/etc/mailcap:/usr/local/etc/mailcap"
  50.       : "/etc/mailcap:/usr/etc/mailcap:/usr/local/etc/mailcap"));
  51. }
  52.  
  53.  
  54. =head1 METHODS
  55.  
  56. =head2 new(OPTIONS)
  57.  
  58.   $mcap = new Mail::Cap;
  59.   $mcap = new Mail::Cap "/mydir/mailcap";
  60.   $mcap = new Mail::Cap filename => "/mydir/mailcap";
  61.   $mcap = new Mail::Cap take => 'ALL';
  62.   $mcap = Mail::Cap->new(take => 'ALL');
  63.  
  64. Create and initialize a new Mail::Cap object.  If you give it an
  65. argument it will try to parse the specified file.  Without any
  66. arguments it will search for the mailcap file using the standard
  67. mailcap path, or the MAILCAPS environment variable if it is defined.
  68.  
  69. There is currently two OPTION implemented:
  70.  
  71. =over 4
  72.  
  73. =item * take =E<gt> 'ALL'|'FIRST'
  74.  
  75. Include all mailcap files you can find.  By default, only the first
  76. file is parsed, however the RFC tells us to include ALL.  To maintain
  77. backwards compatibility, the default only takes the FIRST.
  78.  
  79. =item * filename =E<gt> FILENAME
  80.  
  81. Add the specified file to the list to standard locations.  This file
  82. is tried first.
  83.  
  84. =back
  85.  
  86. =cut
  87.  
  88. sub new
  89. {
  90.     my $class = shift;
  91.     
  92.     if(@_ % 2 == 1)  {unshift @_, 'filename'}
  93.     my %args = @_;
  94.  
  95.     my $take_all = $args{take} && uc $args{take} eq 'ALL';
  96.  
  97.     my $self = bless {}, $class;
  98.     $self->{_count} = 0;
  99.  
  100.     if (defined($args{filename}) && -r $args{filename}) {
  101.     $self->_process_file($args{filename});
  102.     }
  103.  
  104.     if ( !defined($args{filename}) || $take_all)
  105.     {   my $fname;
  106.     foreach $fname (@path) {
  107.         if (-r $fname) {
  108.         $self->_process_file($fname);
  109.         last unless $take_all;
  110.         }
  111.     }
  112.     }
  113.  
  114.     unless ($self->{_count}) {
  115.     # Set up default mailcap
  116.     $self->{'audio/*'} = [{'view' => "showaudio %s"}];
  117.     $self->{'image/*'} = [{'view' => "xv %s"}];
  118.     $self->{'message/rfc822'} = [{'view' => "xterm -e metamail %s"}];
  119.     }
  120.  
  121.     $self;
  122. }
  123.  
  124. sub _process_file
  125. {
  126.     my $self = shift;
  127.     my $file = shift;
  128.     unless($file) { return;}
  129.  
  130.     local *MAILCAP;
  131.     if(open(MAILCAP, $file)) {
  132.     $self->{'_file'} = $file;
  133.     local($_);
  134.     while (<MAILCAP>) {
  135.         next if /^\s*#/; # comment
  136.         next if /^\s*$/; # blank line
  137.         while (s/\\\s*$//) {  # continuation line
  138.         $_ .= <MAILCAP>;
  139.         }
  140.         chomp;
  141.         s/\0//g;            # ensure no NULs in the line
  142.         s/([^\\]);/$1\0/g;  # make field separator NUL
  143.         my @parts = split(/\s*\0\s*/, $_);
  144.         my $type = shift(@parts);
  145.         $type .= "/*" unless $type =~ m,/,;
  146.         my $view = shift(@parts);
  147.         $view =~ s/\\;/;/g;
  148.         my %field = ('view' => $view);
  149.         for (@parts) {
  150.         my($key,$val) = split(/\s*=\s*/, $_, 2);
  151.         if (defined $val) {
  152.             $val =~ s/\\;/;/g;
  153.         } else {
  154.             $val = 1;
  155.         }
  156.         $field{$key} = $val;
  157.         }
  158.         if ($field{'test'}) {
  159.         my $test = $field{'test'};
  160.         unless ($test =~ /%/) {
  161.             # No parameters in test, can perform it right away
  162.             system $test;
  163.             next if $?;
  164.         }
  165.         }
  166.         # record this entry
  167.         unless (exists $self->{$type}) {
  168.         $self->{$type} = [];
  169.         $self->{_count}++; 
  170.         }
  171.         push(@{$self->{$type}}, \%field);
  172.     }
  173.     close(MAILCAP);
  174.     }
  175. }
  176.  
  177. =head2 view($type, $file)
  178.  
  179. =head2 compose($type, $file)
  180.  
  181. =head2 edit($type, $file)
  182.  
  183. =head2 print($type, $file)
  184.  
  185. These methods invoke a suitable progam presenting or manipulating the
  186. media object in the specified file.  They all return C<1> if a command
  187. was found, and C<0> otherwise.  You might test C<$?> for the outcome
  188. of the command.
  189.  
  190. =cut
  191.  
  192. sub view       { my $self = shift; $self->_run($self->viewCmd(@_));    }
  193. sub compose    { my $self = shift; $self->_run($self->composeCmd(@_)); }
  194. sub edit       { my $self = shift; $self->_run($self->editCmd(@_));    }
  195. sub print      { my $self = shift; $self->_run($self->printCmd(@_));   }
  196.  
  197. =head2 viewCmd($type, $file)
  198.  
  199. =head2 composeCmd($type, $file)
  200.  
  201. =head2 editCmd($type, $file)
  202.  
  203. =head2 printCmd($type, $file)
  204.  
  205. These methods return a string that is suitable for feeding to system()
  206. in order to invoke a suitable progam presenting or manipulating the
  207. media object in the specified file.  It will return C<undef> if no
  208. suitable specification exists.
  209.  
  210. =cut
  211.  
  212. sub viewCmd    { shift->_createCommand('view', @_);    }
  213. sub composeCmd { shift->_createCommand('compose', @_); }
  214. sub editCmd    { shift->_createCommand('edit', @_);    }
  215. sub printCmd   { shift->_createCommand('print', @_);   }
  216.  
  217. sub _createCommand
  218. {
  219.     my($self, $method, $type, $file) = @_;
  220.     my $entry = $self->getEntry($type, $file);
  221.     return undef unless $entry;
  222.     if (exists $entry->{$method}) {
  223.     return $self->expandPercentMacros($entry->{$method}, $type, $file);
  224.     } else {
  225.     return undef;
  226.     }
  227. }
  228.  
  229. sub _run
  230. {
  231.     my($self, $cmd) = @_;
  232.     if (defined $cmd) {
  233.     system $cmd;
  234.     return 1;
  235.     }
  236.     0;
  237. }
  238.  
  239. sub makeName
  240. {
  241.     my($self, $type, $basename) = @_;
  242.     my $template = $self->nametemplate($type);
  243.     return $basename unless $template;
  244.     $template =~ s/%s/$basename/g;
  245.     $template;
  246. }
  247.  
  248. =head2 field($type, $field)
  249.  
  250. Returns the specified field for the type.  Returns undef if no
  251. specification exsists.
  252.  
  253. =cut
  254.  
  255. sub field
  256. {
  257.     my($self, $type, $field) = @_;
  258.     my $entry = $self->getEntry($type);
  259.     $entry->{$field};
  260. }
  261.  
  262. =head2 description($type)
  263.  
  264. =head2 textualnewlines($type)
  265.  
  266. =head2 x11_bitmap($type)
  267.  
  268. =head2 nametemplate($type)
  269.  
  270. These methods return the corresponding mailcap field for the type.
  271. These methods should be more convenient to use than the field() method
  272. for the same fields.
  273.  
  274. =cut
  275.  
  276. sub description     { shift->field(shift, 'description');     }
  277. sub textualnewlines { shift->field(shift, 'textualnewlines'); }
  278. sub x11_bitmap      { shift->field(shift, 'x11-bitmap');      }
  279. sub nametemplate    { shift->field(shift, 'nametemplate');    }
  280.  
  281. sub getEntry
  282. {
  283.     my($self, $origtype, $file) = @_;
  284.  
  285.     if ($useCache) {
  286.     if (exists $self->{'_cache'}{$origtype}) {
  287.         return $self->{'_cache'}{$origtype};
  288.     }
  289.     }
  290.  
  291.     my($fulltype, @params) = split(/\s*;\s*/, $origtype);
  292.     my($type, $subtype) = split(/\//, $fulltype, 2);
  293.     $subtype = "" unless defined $subtype;
  294.  
  295.     my $entry;
  296.     for (@{$self->{"$type/$subtype"}}, @{$self->{"$type/*"}}) {
  297.     if (exists $_->{'test'}) {
  298.         # must run test to see if it applies
  299.         my $test = $self->expandPercentMacros($_->{'test'},
  300.                           $origtype, $file);
  301.         system $test;
  302.         next if $?;
  303.     }
  304.     $entry = { %$_ };  # make copy
  305.         last;
  306.     }
  307.     $self->{'_cache'}{$origtype} = $entry if $useCache;
  308.     $entry;
  309. }
  310.  
  311.  
  312. sub expandPercentMacros
  313. {
  314.     my($self,$text,$type,$file) = @_;
  315.     return $text unless defined $type;
  316.     $file = "" unless defined $file;
  317.     my($fulltype, @params) = split(/\s*;\s*/, $type);
  318.     my $subtype;
  319.     ($type, $subtype) = split(/\//, $fulltype, 2);
  320.     my %params;
  321.     for (@params) {
  322.     my($key,$val) = split(/\s*=\s*/, $_, 2);
  323.     $params{$key} = $val;
  324.     }
  325.     $text =~ s/\\%/\0/g;  # hide all escaped %'s
  326.     $text =~ s/%t/$fulltype/g;  # expand %t
  327.     $text =~ s/%s/$file/g;      # expand %s
  328.     {                           # expand %{field}
  329.     local($^W) = 0;  # avoid warnings when expanding %params
  330.     $text =~ s/%\{\s*(.*?)\s*\}/$params{$1}/g;
  331.     }
  332.     $text =~ s/\0/%/g;
  333.     $text;
  334. }
  335.  
  336. # This following procedures can be useful for debugging purposes
  337.  
  338. sub dumpEntry
  339. {
  340.     my($hash, $prefix) = @_;
  341.     $prefix = "" unless defined $prefix;
  342.     for (sort keys %$hash) {
  343.     print "$prefix$_ = $hash->{$_}\n";
  344.     }
  345. }
  346.  
  347. sub dump
  348. {
  349.     my($self) = @_;
  350.     for (keys %$self) {
  351.     next if /^_/;
  352.     print "$_\n";
  353.     for (@{$self->{$_}}) {
  354.         dumpEntry($_, "\t");
  355.         print "\n";
  356.     }
  357.     }
  358.     if (exists $self->{'_cache'}) {
  359.     print "Cached types\n";
  360.     for (keys %{$self->{'_cache'}}) {
  361.         print "\t$_\n";
  362.     }
  363.     }
  364. }
  365.  
  366. =head1 COPYRIGHT
  367.  
  368. Copyright (c) 1995 Gisle Aas. All rights reserved.
  369.  
  370. This library is free software; you can redistribute it and/or
  371. modify it under the same terms as Perl itself.
  372.  
  373. =head1 AUTHOR
  374.  
  375. Gisle Aas <aas@oslonett.no> 
  376.  
  377. Modified by Graham Barr <gbarr@pobox.com>
  378.  
  379. Maintained by Mark Overmeer <mailtools@overmeer.net>
  380.  
  381. =cut
  382.  
  383.  
  384. 1;
  385.