#!/usr/bin/perl
#
# Version 5
#

use strict;
use Time::Local;
use vars qw($date_time $account_string $interval $prefix $err_name); 
use vars qw($hold $join_list $keep_list $mail_options $mail_list $name);
use vars qw($priority  $out_name $destination $restart $shell);
use vars qw($variable_list $vars $no_number $res $extra $ignore);
use vars qw(@arg @attrs $file $first_line @script);

if($#ARGV<1){
	print <<_Usage;
Usage: qsub [-a date_time] [-A account_string] [-c checkpoint_options]
       [-C directive_prefix] [-d path] [-e path] [-f] [-h]
       [-I ] [-j join ] [-k keep ] [-l resource_list ]
       [-m  mail_options] [-M user_list] [-N name] [-o path]
       [-p priority] [-P user[:group]] [-q destination] [-r c] [-S path_list]
       [-u  user_list] [-v  variable_list]
       [-V ] [-W additional_attributes] [-X] [-z] [script|-] [args] 

_Usage
	exit(1);
}
	

$ENV{PBS_O_HOST}=`hostname`;
$ENV{PBS_SERVER}=$ENV{PBS_O_HOST};
$ENV{PBS_O_WORKDIR}=`pwd`;
$ENV{PBS_ENVIRONMENT}='PBS_INTERACTIVE';


GetOptsTillCan('a=s'          =>\$date_time,      #указать время, после которого задача может идти на счёт
               'A=s'          =>\$account_string, #указать имя учётной записи, под которой будет запущено приложение
               'c=i'          =>\$interval,       #указывает интервал постановки контрольных точек при выполнении задачи
               'C=s'          =>\$prefix,         #префикс для поиска директив в скрипте запуска программы
               'e=s'          =>\$err_name,       #указывает путь к файлу, куда будет перенаправлен поток вывода ошибок
               'h='           =>\$hold,           #задача должны быть автоматически остановлена после постановки в очередь
               'j=s'          =>\$join_list,      #указывает потоки, которые должны быть перенаправлены в стандартный поток вывода
               'I='           =>\$ignore,
               'k=s'          =>\$keep_list,      #указывает, какие потоки вывода должны сохраняться на вычислительных узлах
               'l=s'          =>\$res,
               'm=s'          =>\$mail_options,   #указывает, в каких случаях система очередей должна оповещать пользователя по электронной почте об изменении статуса задачи
               'M=s'          =>\$mail_list,      #задаёт список email-адресов для оповещения пользователей об изменении статуса задачи
               'N=s'          =>\$name,           #задаёт имя задачи
               'o=s'          =>\$out_name,       #задаёт путь к файлу, куда будет перенаправлен стандартный поток вывода
               'p=i'          =>\$priority,       #задаёт приоритет задачи
               'q=s'          =>\$destination,    #указывает имя очереди, куда будет поставлена задача
               'r=s'          =>\$restart,        #y|n указывает, можно ли перезапускать задачу
               'S=s'          =>\$shell,          #указывает программу оболочки (shell), под которой будет запущена задача
               'v=s'          =>\$variable_list,  #список переменных, которые будут доступны задаче после запуска
               'V='           =>\$vars,           #указывает, что все переменные окружения должны быть доступны задаче
               'W=s'          =>\$extra,
               'z='           =>\$no_number,      #предписывает не выводить номер задачи в стандартный поток вывода после постановки задачи в очередь
               );

if($date_time ne ''){
	my $time;
	# time to start task after ( [[CC]YY]MMDDhhmm[.ss])
	if($date_time =~ /(\d\d)?(\d\d)?(\d\d)(\d\d)(\d\d)(\d\d)(\.\d\d)?/){
		my ($y,$m,$d,$h,$n)=($2,$3,$4,$5,$6);
		if($y ne '' and $m eq ''){
			$m=$y;
			$y='';
		}
		$time = timelocal(0,$n,$h,$d,$m,$y);
	}
	else{
		die "Invalid -a time format. [[CC]YY]MMDDhhmm format must be used.\n";
	}
	
	push @attrs, "aftertime#${time}";
}

if($account_string ne ''){
	# use different account
	warn "-A option is not implemented.\n";
}

if($interval >0){
	# checkpoints interval
	push @attrs, "checkpoint_interval#${interval}";
}

if($prefix eq ''){
	# Use default prerix for options scanning in script body
	$prefix=$ENV{PBS_DPREFIX};
	$prefix ||= '#PBS'; 
}

if($err_name ne ''){
	# stderr redirect
	push @arg, '-3', $err_name;
}

if($hold >0){
	# hold task just after submit
	push @arg, '-H';
}

if($join_list ne ''){
	#!!!!!!!!!!!!!!!!!
}

if($keep_list ne ''){
	warn "-k is not supported now.\n";
}

if($mail_options ne ''){
	# set mailing options
	$mail_options =~ y/#//d;
	push @attrs, "mailopts#${mail_options}";
}
if($mail_list ne ''){
	# set list of emails
	$mail_list =~ y/#//d;
	push @attrs, "maillist#${mail_list}";
}

if($name ne ''){
	warn "-N option is not implemented\n";
}

if($out_name ne ''){
	# stdout redirect
	push @arg, '-2', $out_name;
}

if($priority >0 ){
	# set priority
	push @arg, '-P', $priority;
}

if($destination ne ''){
	# set queue
	push @arg, '-q', $destination;
}
if($restart eq 'y'){
	# set restart mode
	push @attrs, 'restart#1';
}

if($shell ne ''){
	# use custom shell
	$shell =~ y/\n\r\0//d;
	$first_line="#!$shell\n";
}

if($variable_list ne ''){
	# export theese variable to task
	push @arg, '-N', quotemeta("PBS_O_HOST,PBS_SERVER,PBS_O_WORKDIR,PBS_ENVIRONMENT,TZ,HOME,LANG,LOGNAME,PATH,MAIL,SHELL,$variable_list");
}

if($vars >0){
	# export all variables
	push @arg, '-E';
}
if($no_number >0){
	#don't print task id to stdout
	push @arg, '-Q';
}

if($res ne ''){
	# add resources list...
	foreach my $l (split(/,/, $res)){
		add_res($l);
	}
}

if($extra ne ''){
	my ($var,$val);
	# extra options
	while($extra =~ s/([^=]+)=([^,]+),?//){
		$var=$1;
		$val=$2;
		
		if($var eq 'depend'){
			if($var =~ s/([^:]+)://){
				my $dep=$1;
				if($dep eq 'after' or $dep eq 'afterany'){
					push @arg, '-z', 'a', '-y', split(/,/,$val);
				}
				elsif($dep eq 'afterok'){
					push @arg, '-z', 'a', '-Y', split(/,/,$val);
				}
				elsif($dep eq 'afternotok'){
					push @arg, '-z', 'a', '-Z', split(/,/,$val);
				}
			}
		}
		else{
			warn "$var is not implemented\n";
		}
	}
}

if($first_line ne ''){
	push @script, $first_line;
}

if($ARGV[0] ne ''){
	if($ARGV[0] eq '-'){
		open(IN,"<&=STDIN");
	}
	else{
		die "Cannot open '$ARGV[0]'\n"
			unless(open(IN, "<$ARGV[0]"));
		$file=$ARGV[0];
	}
}
else{
	open(IN,"<&=STDIN");
}

# read the script!
while(<IN>){
	push @script, $_ if($file eq '');

	if(/^${prefix}\s+(.*)/){
		add_res($1);
	}
}
close IN;

# create new script file, if needed
if($file eq '' or $first_line ne ''){
	$file="stdin.$$" if($file eq '');

	if(open(SCRIPT,">$file")){
		if( $first_line ne '' ){
			print SCRIPT $first_line;
		}
		print SCRIPT @script;
		close SCRIPT;
	}
	else{
		die "Cannot create intermediate script file $file ($!)\n";
	}
}

# add attributes...
if($#attrs>=0){
	push @arg, '-x', join('#', @attrs);
}

# and scriptname and args!
shift @ARGV;

push @arg, '-L', 'script', '-c', join(' ',$file,@ARGV);


# submit!
exec("/usr/bin/cleo-client",@arg);
warn "Cannot exec client application...\n";
exit(10);

#
#  Gets opts like this: ('X=i', \$Xoption,...) (this means "option '-X 10' to variable $Xoption=10)
#  The scans command line for options till founds argument '--' or non-specified
#  option, or not '-' prefixed argument.
#  Specifications of options (what goes after 'X='):
#  i - integer
#  s - string
#  + - cumulative value (variable MUST be a list)
#  nothing - flag
#
sub GetOptsTillCan{

  my %args=@_;
  my ($arg,$a_key,$a_value,$a,$next,%types);

  foreach $arg (keys(%args)){
    $arg =~ /^(\S+)(\=)(.*)/ or next;
    $a_key=$1;
    $a_value=$args{$arg};
    $types{$a_key} = $3;

    delete $args{$arg};
    $args{$a_key} = $a_value;
  }

  while($next=shift @ARGV){
    last if(substr($next,0,1) ne '-');
    last if($next eq '--');
    $a=substr($next,1);
    last unless(exists $args{$a});
    undef $next;
    if(($types{$a} eq 'i') || ($types{$a} eq 's')){
      $a=$args{$a};
      $$a=shift @ARGV;
    }
    elsif($types{$a} eq ''){
      $a=$args{$a};
      $$a=1;
    }elsif($types{$a} eq '+'){
      $a=$args{$a};
      push @$a, shift @ARGV;
    }
  }
  unshift @ARGV, $next if(defined $next);
}


sub add_res($){
	# add new resource
	my ($name,$val);
	if($_[0] =~ /([^=]+)\s*=\s*(.*)/){
		($name,$val)=($1,$2);
		if($name eq 'arch'){
			#ignore
		}
		elsif($name eq 'cput' or
			  $name eq 'walltime' or
			  $name eq 'pcput'){
			if($val =~ /^((\d+):)?((\d\d):)?(\d\d)/){
				my ($HH, $MM, $SS)=($2,$4,$5);
				if($MM eq ''){
					$MM=$HH;
					$HH=0;
				}
				$SS+=$MM*60+$HH*3600;
				push @arg, '-l', $SS;
			}
			else{
				warn "Illegal 'cput' resource value: $val\n";
			}
		}
		elsif($name eq 'epilogue'){
			push @attrs, "epilogue#${val}";
		}
		elsif($name eq 'file'){
			# ignore
		}
		elsif($name eq 'host'){
			# ignore
		}
		elsif($name eq 'mem'){
			# ignore
		}
		elsif($name eq 'nice'){
			# ignore
		}
		elsif($name eq 'nodes'){
			my $ppn=0;
			my $np=0;
			foreach my $spec (split(/\+/, $val)){
				# simplify the request for now...
				# !!!!!
				# TASK: fix this in the future versions
				if($spec =~ /ppn=(\d+)/){
					$ppn=$1;
				}
				if($spec =~ /^(\d+)/){
					$np+=$1;
				}
			}
			if($np>0){
				push @arg, '-n', $np;
				if($ppn>0){
					push @attrs, "ppn=$np";
				}
			}
		}
		elsif($name eq 'opsys'){
			# ignore
		}
		elsif($name eq 'other'){
			# ignore
		}
		elsif($name eq 'pmem'){
			# ignore
		}
		elsif($name eq 'pvmem'){
			# ignore
		}
		elsif($name eq 'vmem'){
			# ignore
		}
		elsif($name eq 'software'){
			# ignore
		}
		elsif($name eq 'procs'){
			if($val =~ /^\d+$/){
				push @arg, '-n', $val;
			}
			else{
				warn "procs must be integer\n";
			}
		}
		elsif($name eq 'prologue'){
			push @attrs, "epilogue#${val}";
		}
	}
	else{
		warn("Bad resource request: $_[0]\n");
	}
}


