# This file belongs to TLPM v2.14, TeX Live Package Manager # Public Domain, P.Jackowski@gust.org.pl # cmdline parsing # surely we can't rely on windows shell behaviour, so we make all the parsing. # some day I'd like to use native shell for u*x though... sub resolve_env # resolve environment variables { my $str = \$_[0]; while($$str =~ s/$reg_envvar/$ENV{$1}/){} } *OUT; *LOG; $tlpm_output = undef; $reg_redir = qr/(>>?|\|)\s*(.+?)\s*\z/; sub set_out { my $str = \$_[0]; if($$str =~ s/$reg_redir//) { $tlpm_output = $2; if($1 eq '|') { $tlpm_redir = 2; } else { $tlpm_redir = 1; &norm_path($tlpm_output); # $tlpm_output = &rel2abs($tlpm_output,$curr_dir); } $tlpm_output = $1 . $tlpm_output; } else { $tlpm_redir = 0; } } sub open_out { if(defined $tlpm_output) { if(open(OUT,$tlpm_output)) { select OUT; } else { &close_out; return $error{'wrong_out'} -> ($tlpm_output); } } } sub close_out { close OUT; $tlpm_output = undef; select STDOUT; } sub open_log { my $log = $tl_target . $tlpm_log; if(open(LOG,">>$log")) { printf LOG ($row_fmt . "%s\n" , $message_prefix . $tlpm_prompt . $cmd_line , "[" . &date . "]"); &talk2log(); return(0); } else { &undef_target(); return $error{'wrong_out'} -> ($log); } } sub close_log { printf LOG ($row_fmt . "%s\n" , $message_prefix . "done" , "[" . &date . "]"); close LOG; ¬2log(); } $reg_white = qr/\A\s+|\A=/; $reg_dquot = qr/\A\"(.*?)\"/; $reg_squot = qr/\A\'(.*?)\'/; $reg_param = qr/\A([^-]\S*)/; $reg_sopts = qr/\A[-](\w+)/; $reg_dopts = qr/\A[-]{2}(\w+)/; sub parse_cmd { my $str = shift; my (@opt,@opts); while($str ne '') { $str =~ s/$reg_white// and next or $str =~ s/$reg_squot// and push(@opt,"$1") or $str =~ s/$reg_dquot// and push(@opt,"$1") or $str =~ s/$reg_param// and push(@opt,"$1") or $str =~ s/$reg_dopts// and push(@opt,"$opt_prefix$1") or $str =~ s/$reg_sopts// and @opt = (@opt,map {"$opt_prefix$_"} split('',$1)) or $error{'wrong_syn'} -> ($str) and return(); } while(defined($str = shift @opt)) { push(@opts,$str); if($str =~ /$reg_option/ && $opt[0] =~ /$reg_option/) { push(@opts,''); } } return @opts; } sub is_opt { my $arg = shift; my $reg; foreach(@_) { $reg = qr/$_\z/; return $true if $arg =~ /$reg_option$reg/; } return $false; } sub no_opt { return ($_[0] =~ /$reg_option/ ? $false : $true); } sub rem_opt { map {s/$reg_option//} @_; } $opt_prefix = 'opt:'; $reg_option = qr/\A$opt_prefix/o; 1;