#!/usr/bin/perl -w
#---------------------------------------------
#   xdg-launch
#
#   Interpreter for .desktop files.
#
#   Copyright 2009, Daniel Ruoso <daniel@ruoso.com>
#
#   LICENSE:
#
#   Permission is hereby granted, free of charge, to any person obtaining a
#   copy of this software and associated documentation files (the "Software"),
#   to deal in the Software without restriction, including without limitation
#   the rights to use, copy, modify, merge, publish, distribute, sublicense,
#   and/or sell copies of the Software, and to permit persons to whom the
#   Software is furnished to do so, subject to the following conditions:
#
#   The above copyright notice and this permission notice shall be included
#   in all copies or substantial portions of the Software.
#
#   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
#   OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
#   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
#   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
#   OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
#   ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
#   OTHER DEALINGS IN THE SOFTWARE.
#
#---------------------------------------------


# The purpose of this script is to be used as shbang for .desktop
# files. The Desktop Environments are not supposed to execute this
# utility by themselves, but rather execute the .desktop file itself
# that should have this utility in its shbang line.
#
# That assuming the DE won't execute .desktop files that don't have
# the x bit set.

use strict;
use warnings;

my $fork_limit = $::ENV{XDG_LAUNCH_FORK_LIMIT} || 10;

# We are going to read the file according to
# http://standards.freedesktop.org/desktop-entry-spec/1.1/
# Quotes from the spec will appear as in
#{ This is a quote from spec }

# We're goint to take the file to read.
my $filename = shift;

#{ Desktop entry files should have the .desktop extension }
die 'Invalid Desktop Entry. Bad name: '.$filename
  if $filename !~ /\.desktop$/;

#{ Desktop entry files are encoded in UTF-8. }
open my $file, '<:utf8', $filename or die 'Could not open launcher: '.$!;

#{ A file is interpreted as a series of lines that are separated by
#  linefeed characters. }
local $/ = "\n";

#{ Lines beginning with a # and blank lines are considered comments
#  and will be ignored }

# note that the spec doesn't mention trailing whitespaces, so let's
# assume there shouldn't be any.  we also are not going to reproduce
# this file, so we can simply ignore the comments.
my @lines =
  grep { $_ !~ /^\#/ &&
           $_ =~ /\S/ }
  map { chomp; $_ } <$file>;

close $file;

#{ All {key,value} pairs following a group header until a new group
#  header belong to the group. }

# the name of the current group
my $current_group = undef;

# { group => { key => value }
my $launcher_data = {};

# { locale => { group => { key => value } } }
my $localized_data = {};

foreach my $line (@lines) {
  #{ A group header with name groupname is a line in the format:
  #
  #    [groupname]
  #
  #  Group names may contain all ASCII characters except for [ and ]
  #  and control characters. }

  # note that the spec doesn't mention trailing whitespaces, so let's
  # assume there shouldn't be any.
  if ($line =~
      /^\[        # open square bracket
      ([^\[\]]+)  # all ASCII characters except for [ and ]
       \]         # close square bracket
      /x) {
    my $this_group = $1;
    #{ The basic format of the desktop entry file requires that there
    #  be a group header named Desktop Entry. There may be other groups
    #  present in the file, but this is the most important group which
    #  explicitly needs to be supported. This group should also be used
    #  as the "magic key" for automatic MIME type detection. There
    #  should be nothing preceding this group in the desktop entry file
    #  but possibly one or more comments. }

    # This means that if the first group found is not "Desktop Entry"
    # then this file is invalid.
    if ((not defined $current_group) &&
        ($this_group ne 'Desktop Entry')) {
      die 'Invalid file: First group should be Desktop Entry.';
    } else {
      $current_group = $this_group;
    }

  } elsif
    #{  Entries in the file are {key,value} pairs in the format:
    #
    #       Key=Value
    #

    #   Space before and after the equals sign should be ignored; the
    #   = sign is the actual delimiter.

    #   Only the characters A-Za-z0-9- may be used in key names.

    #   As the case is significant, the keys Name and NAME are not
    #   equivalent.

    #   Multiple keys in the same group may not have the same
    #   name. Keys in different groups may have the same name. }
    ($line =~
     /^([A-Za-z0-9\-]+)\s*\=\s*(.+)$/x) {
    my ($key, $value) = ($1, $2);

    # there can't be entries without groups.
    die 'Invalid File: Key=Value should be inside a group.'
      unless $current_group;

    if ($key =~ /^(Type|Version|Name|GenericName
                   |Comment|Icon|TryExec|Path
                   |MimeType|Categories|StartupWMClass|URL)$/x) {
      # string type
      #{ The escape sequences \s, \n, \t, \r, and \\ are supported for
      #  values of type string and localestring }
      $value =~ s/\\s/ /gs;
      $value =~ s/\\n/\n/gs;
      $value =~ s/\\t/\t/gs;
      $value =~ s/\\r/\r/gs;
      $value =~ s/\\/\\/gs;
    } elsif ($key =~ /^(NoDisplay|Hidden|Terminal|StartupNotify)$/x) {
      # boolean type
      #{ Values of type boolean must either be the string true or false. }
      die 'Invalid file: boolean fields must be either "true" or "false"'
        unless $value =~ /^(true|false)$/;
    } elsif ($key eq 'Exec') {
      #{ The Exec Key }

      # The processing of the exec key is considerably confusing.  but
      # it might require information of other keys, so let's leave it
      # to a second stage.

    }
    # the spec specifies the format for numeric fields, but defines no
    # numeric fields.

    $launcher_data->{$current_group}{$key} = $value;

  } elsif
    #{ Keys with type localestring may be postfixed by [LOCALE], where
    #  LOCALE is the locale type of the entry. LOCALE must be of the
    #  form lang_COUNTRY.ENCODING@MODIFIER, where _COUNTRY, .ENCODING,
    #  and @MODIFIER may be omitted. If a postfixed key occurs, the same
    #  key must be also present without the postfix. }
    ($line =~
     /^([A-Za-z0-9\-]+)    # Key
       \[(                 # Locale, formed of:
        [a-z]+                   # lang
        (?:\_[a-zA-Z]+)?         # country, may be omitted
        (?:\.[a-zA-Z0-9\_\-]+)?  # encoding, may be omitted
        (?:\@[a-zA-Z0-9\_\-]+)?  # modifier, may be omitted
       )\]
       \s*\=\s*(.*)     # Value.
       $/x) {
    my ($key, $locale, $value) = ($1, $2, $3);

    # The spec doesn't state this very clearly, but it seems that in
    # key names without a 'X-' prefix, you can only get localized
    # variants for "Name", "GenericName", "Comment" and "Icon"

    die 'Invalid File: Key '.$key.' is not subject to localization.'
      if $key !~ /^(X-.+|(Generic)?Name|Comment|Icon)/;

    #{ The escape sequences \s, \n, \t, \r, and \\ are supported for
    #  values of type string and localestring }
    $value =~ s/\\s/ /gs;
    $value =~ s/\\n/\n/gs;
    $value =~ s/\\t/\t/gs;
    $value =~ s/\\r/\r/gs;
    $value =~ s/\\/\\/gs;

    $localized_data->{$locale}{$current_group}{$key} = $value;
  } else {
    die 'Invalid File: Unrecognized line: '.$line;
  }
}

# let's check for required keys:
die 'Invalid File: Missing required keys.' unless
  exists $launcher_data->{'Desktop Entry'}{'Type'} &&
  exists $launcher_data->{'Desktop Entry'}{'Name'} &&
  (($launcher_data->{'Desktop Entry'}{'Type'} eq 'Application' &&
    exists $launcher_data->{'Desktop Entry'}{'Exec'}) ||
   ($launcher_data->{'Desktop Entry'}{'Type'} eq 'Link' &&
    exists $launcher_data->{'Desktop Entry'}{'URL'}) ||
   ($launcher_data->{'Desktop Entry'}{'Type'} eq 'Directory') || 1);

#{ the same key must be also present without the postfix }
foreach my $locale (keys %{$localized_data}) {
  foreach my $group (keys %{$localized_data->{$locale}}) {
    foreach my $key (keys %{$localized_data->{$locale}{$group}}) {
      die 'Invalid File: Localized data must have the plain version.'
        unless exists $launcher_data->{$group}{$key};
    }
  }
}

exit 0 if $launcher_data->{'Desktop Entry'}{'Type'} eq 'Directory';

if ($launcher_data->{'Desktop Entry'}{'Type'} eq 'Link') {
  # If the type is link, it contains a simple URL, which, apparently
  # should be delivered to xdg-open. We use exec because we no longer
  # need to take care of that.
  exec '/usr/bin/env', 'xdg-open', $launcher_data->{'Desktop Entry'}{'URL'}
    or die 'Could not execute env';

} elsif ($launcher_data->{'Desktop Entry'}{'Type'} eq 'Application') {
  if (exists $launcher_data->{'Desktop Entry'}{'TryExec'}) {
    #{ Path to an executable file on disk used to determine if the
    #  program is actually installed. If the path is not an absolute
    #  path, the file is looked up in the $PATH environment variable. If
    #  the file is not present or if it is not executable, the entry may
    #  be ignored (not be used in menus, for example). }
    my $try_exec = $launcher_data->{'Desktop Entry'}{'TryExec'};
    if ($try_exec =~ /^\//) {
      # this is an absolute filename.
      exit 0 unless -x $try_exec;
    } else {
      exit 0 unless
        grep { -x $_ }
          map { $_.'/'.$try_exec }
            split /\:/, $::ENV{PATH};
    }
  }

  my $exec_str = $launcher_data->{'Desktop Entry'}{'Exec'};
  my @parts = tokenize_execstr($exec_str);
  my $program = shift @parts;

  if ($program !~ /^\//) {
    # this is not an absolute filename.
    ($program) =
      grep { -x $_ }
        map { $_.'/'.$program }
          split /\:/, $::ENV{PATH};
  }

  exec $program, @parts
    or die 'Could not exec program '.$program.': '.$!;

} else {
  # The spec doesn't state which field represent the directory itself,
  # nor the action that should be taken.
  #{ This specification defines 3 types of desktop entries: Application
  #  (type 1), Link (type 2) and Directory (type 3). To allow the addition
  #  of new types in the future, implementations should ignore desktop
  #  entries with an unknown type. }
  exit 0;

}


sub tokenize_execstr {
  my $exec_str = shift;

  # The spec is really confusing, but it seems that quotes have
  # precedence over everything else.
  my @tokens =
    grep { /\S/ } # we may capture some trailing spaces...
      ($exec_str =~ /\s*  # spaces are the separators
                     (    # each token
                       (?:   # quoted
                         \"    # start with double-quotes
                         (?:   # contains
                           [^\"\\\`\$]  # anything but "\`$
                         |              # or
                           \\\\         # \\
                         |              # or
                           \\\`         # \`
                         |              # or
                           \\\$         # \$
                         |              # or
                           \\\"         # \"
                         )+    # zero or more
                         \"   # end with double-quotes
                       )
                     |      # or unquoted
                       \S+ # characters
                     )
                     \s* # spaces
                    /gx);

  my @final;
  my $check_duplicates = 0;

 TOKEN:
  foreach my $token (@tokens) {
    if ($token =~ /^\"/) {
      #{ Implementations must undo quoting before expanding field codes
      #  and before passing the argument to the executable
      #  program. Reserved characters are space (" "), tab, newline,
      #  double quote, single quote ("'"), backslash character ("\"),
      #  greater-than sign (">"), less-than sign ("<"), tilde ("~"),
      #  vertical bar ("|"), ampersand ("&"), semicolon (";"), dollar sign
      #  ("$"), asterisk ("*"), question mark ("?"), hash mark ("#"),
      #  parenthesis ("(") and (")") and backtick character ("`"). }
      $token =~ s/^\"|\"$//g;
      $token =~ s/\\\"/\"/g;
      $token =~ s/\\ / /g;
      $token =~ s/\\t/\t/g;
      $token =~ s/\\n/\n/g;
      $token =~ s/\\\'/\'/g;
      $token =~ s/\\\\/\\/g;
      $token =~ s/\\\>/>/g;
      $token =~ s/\\\</</g;
      $token =~ s/\\\|/|/g;
      $token =~ s/\\\&/\&/g;
      $token =~ s/\\;/;/g;
      $token =~ s/\\\$/\$/g;
      $token =~ s/\\\#/#/g;
      $token =~ s/\\\(/(/g;
      $token =~ s/\\\)/)/g;
      push @final, $token;

    } else {
      #{ Field codes must not be used inside a quoted argument }
      if ($token eq '%i' &&
          exists $launcher_data->{'Desktop Entry'}{'Icon'} &&
          $launcher_data->{'Desktop Entry'}{'Icon'} =~ /\S/) {
        push @final, '--icon', $launcher_data->{'Desktop Entry'}{'Icon'};
      } elsif ($token eq '%k') {
        push @final, $filename;
      } elsif ($token eq '%c') {
        my ($valid) =
          grep { exists $localized_data->{$_}{'Desktop Entry'}{'Name'} }
            gen_locale_variants();
        if ($valid) {
          push @final, $localized_data->{$valid}{'Desktop Entry'}{'Name'};
        } else {
          push @final, $launcher_data->{'Desktop Entry'}{'Name'};
        }
      } elsif ($token eq '%U') {
        die 'Invalid File: %U, %F, %u and %f should not appear more than once'
          if $check_duplicates;
        $check_duplicates = 1;
        push @final, @::ARGV;

      } elsif ($token eq '%F') {
        die 'Invalid File: %U, %F, %u and %f should not appear more than once'
          if $check_duplicates;
        $check_duplicates = 1;
        push @final, make_items_local(\@::ARGV);

      } elsif ($token eq '%u') {
        die 'Invalid File: %U, %F, %u and %f should not appear more than once'
          if $check_duplicates;
        $check_duplicates = 1;

        die 'Invalid invocation: Would need to spawn to many processes.'
          if scalar @::ARGV > $fork_limit;

        my @all = @::ARGV;

        while (scalar @all > 2) {
          my $pid = fork;
          die 'Invocation error. Could not fork.' unless defined $pid;
          if ($pid) {
            if (scalar @all == 2) {
              push @final, pop @all;
              next TOKEN;
            }
          } else {
            push @final, shift @all;
            next TOKEN;
          }
        }

      } elsif ($token eq '%f') {
        die 'Invalid File: %U, %F, %u and %f should not appear more than once'
          if $check_duplicates;
        $check_duplicates = 1;

        die 'Invalid invocation: Would need to spawn to many processes.'
          if scalar @::ARGV > $fork_limit;

        my @all = make_items_local(\@::ARGV);

        while (scalar @all > 2) {
          my $pid = fork;
          die 'Invocation error. Could not fork.' unless defined $pid;
          if ($pid) {
            if (scalar @all == 2) {
              push @final, pop @all;
              next TOKEN;
            }
          } else {
            push @final, shift @all;
            next TOKEN;
          }
        }

      } else {
        push @final, $token;
      }
    }
  }

  return @final;
}

sub gen_locale_variants {
  my $l = $::ENV{LANG};
  my ($lang, $country, $enc, $var) =
    ($l =~ / ([a-z]+)               # lang
             (\_[a-zA-Z]+)?         # country, may be omitted
             (\.[a-zA-Z0-9\_\-]+)?  # encoding, may be omitted
             (\@[a-zA-Z0-9\_\-]+)?  # modifier, may be omitted
           /x);

  my @variants;
  push @variants, $lang.$country.$enc.$var if $lang && $country && $enc && $var;
  push @variants, $lang.$country.$enc if $lang && $country && $enc;
  push @variants, $lang.$country.$var if $lang && $country && $var;
  push @variants, $lang.$country if $lang && $country;
  push @variants, $lang.$enc.$var, if $lang && $enc && $var;
  push @variants, $lang.$enc if $lang && $enc;
  push @variants, $lang.$var, if $lang && $var;
  push @variants, $lang  if $lang;
  return @variants;
}

sub make_items_local {
  # this should really be a xdg-foo script, that creates a temp dir,
  # then returns the local names. Optionally, this could start a
  # watchdog for modifications that could ask if the user wants to
  # upload the file back (thinking about ssh://, smb:// etc).  this
  # should also present a nice screen with the download progress.
  my $arr = shift;
  return map { make_item_local($_) } @{$arr};
}

sub make_item_local {
  my $item = shift;
  if ($item =~ /^\//) {
    # absolute file.
    return $item;
  } elsif ($item =~ /^file\:(.+)$/) {
    # file url
    return $1;
  } elsif ($item !~ /^[a-zA-Z0-9]+\:/) {
    # this doesn't look like an URI
    return $item;
  } else {
    # We don't support this, but gnome doesn't seem to support it
    # today, so I think that should be ok.
    die 'Invocation Error: Unsupported URI scheme: '.$item;
  }
}