package File::MimeInfo::Rox;

use strict;
use warnings;
use Carp;
use File::BaseDir qw/config_home data_dirs/;
use File::Spec;
require Exporter;

our @ISA = qw(Exporter);
our @EXPORT = qw(mime_exec mime_system);
our @EXPORT_OK = qw(suggest_script_name);
our %EXPORT_TAGS = (magic => \@EXPORT);
our $VERSION = '0.34';
our @choicespath = (
    config_home('rox.sourceforge.net'),
    File::Spec->catdir($ENV{HOME}, 'Choices'),
    data_dirs('Choices'),
);
our ($DEBUG);

sub import {
    my $parent = (grep {$_ eq q/:magic/} @_)
        ? q/File::MimeInfo::Magic/
        : q/File::MimeInfo/;
    eval "use $parent";
    die $@ if $@;
    goto \&Exporter::import;
}

sub mime_system { _do_mime('system', @_) }
sub mime_exec   { _do_mime('exec',   @_) }

sub _do_mime {
    my ($act, $file, $mimet) = (shift, shift, shift);

    $mimet ||= mimetype($file);
    return undef unless $mimet;
    print "Using mimetype: $mimet\n" if $DEBUG;

    my $script = _locate_script($mimet);
    return undef unless $script;

    print "Going to $act: $script $file\n" if $DEBUG;
    ($act eq 'exec')
        ? exec($script, $file, @_)
        : (system($script, $file, @_) == 0)
            or croak "couldn't $act: $script $file";
    42;
}

sub _locate_script {
    my $mime = shift;
    $mime =~ /^(\w+)/;
    my $media = $1;
    $mime =~ s#/#_#;
    my @p = $ENV{CHOICESPATH}
        ? split(/:/, $ENV{CHOICESPATH})
        : (@choicespath);
    my $script;
    for (
        map("$_/MIME-types/$mime", @p),
        map("$_/MIME-types/$media", @p)
    ) {
        print "looking for: $_\n" if $DEBUG;
        next unless -e $_;
        $script = $_;
        last;
    }
    return undef unless $script;
    $script = "$script/AppRun" if -d $script;
    return -f $script ? $script : undef;
}

sub suggest_script_name {
    my $m = pop;
    $m =~ s#/#_#;
    my @p = $ENV{CHOICESPATH}
        ? split(/:/, $ENV{CHOICESPATH})
        : (@choicespath);
    return "$p[0]/MIME-types", $m;
}

1;

__END__

=head1 NAME

File::MimeInfo::Rox - Open files by mimetype "Rox style"

=head1 SYNOPSIS

  use File::MimeInfo::Magic;
  use File::MimeInfo::Rox qw/:magic/;

  # open some file with the appropriate program
  mime_system($somefile);

  # more verbose version
  my $mt = mimetype($somefile)
    || die "Could not find mimetype for $somefile\n";
  mime_system($somefile, $mt)
    || die "No program to open $somefile available\n";


=head1 DESCRIPTION

This module tries to mimic the behaviour of the rox file
browser L<http://rox.sf.net> when "opening" data files.
It determines the mime type and searches in rox's C<Choices>
directories for a program to handle that mimetype.

See the rox documentation for an extensive discussion of this
mechanism.

=head1 EXPORT

The methods C<mime_exec> and C<mime_system> are exported,
if you use the export tag C<:magic> you get the same methods
but L<File::MimeInfo::Magic> will be used for mimetype lookup.

=head1 ENVIRONMENT

The environment variable C<CHOICESPATH> is used when searching
for rox's config dirs. It defaults to
C<$ENV{HOME}/Choices:/usr/local/share/Choices:/usr/share/Choices>

=head1 METHODS

=over 4

=item C<mime_system($file)>

=item C<mime_system($file, $mimetype, @_)>

Try to open C<$file> with the appropriate program for files of
it's mimetype. You can use C<$mimetype> to force the mimetype.
Also if you already know the mimetype it saves a lot of time
to just tell it.

If either the mimetype couldn't be determined or
no appropriate program could be found C<undef> is returned.
If the actual L<system> fails an exception is raised.

All remaining arguments are passed on to the handler.

=item C<mime_exec($file)>

=item C<mime_exec($file, $mimetype, @_)>

Like C<mime_system()> but uses L<exec> instead of L<system>,
so it B<never returns> if successful.

=item C<suggest_script_name($mimetype)>

Returns the list C<($dir, $file)> for the suggested place
to write new script files (or symlinks) for mimetype C<$mimetype>.
The suggested dir doesn't need to exist.

=back

=head1 AUTHOR

Jaap Karssenberg E<lt>pardus@cpan.orgE<gt>
Maintained by Michiel Beijen E<lt>mb@x14.nlE<gt>

=head1 COPYRIGHT

Copyright (c) 2003, 2012 Jaap G Karssenberg. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 SEE ALSO

L<File::MimeInfo>,
L<File::MimeInfo::Magic>,
L<http://rox.sourceforce.net>

=cut