diff options
Diffstat (limited to 'Master/setuptl/TLPM/common.pm')
-rw-r--r-- | Master/setuptl/TLPM/common.pm | 253 |
1 files changed, 0 insertions, 253 deletions
diff --git a/Master/setuptl/TLPM/common.pm b/Master/setuptl/TLPM/common.pm deleted file mode 100644 index 02b871ff891..00000000000 --- a/Master/setuptl/TLPM/common.pm +++ /dev/null @@ -1,253 +0,0 @@ -# This file belongs to TLPM v2.21, TeX Live Package Manager -# Public Domain, P.Jackowski@gust.org.pl - -# common procedures; -# to avoid any stdlib dependencies, we implement a couple of trivial procedures here - -# operations on paths - -sub dirsep2dirsep -{ - my $path = shift; - $path =~ s/$reg_dirsep/$chr_dirsep/g; - return $path; -} - -sub split_path -{ - return split(/$reg_dirsep/,$_[0]); -} - -sub join_path -{ - return join($chr_dirsep,@_); -} - -sub join_list -{ - return join(" ",@_); -} - -sub norm_path -{ - map - { - chomp;s/\A\s+//; - #s/$reg_dirsep+/$chr_dirsep/g; - s/$reg_dirsep\z//g; - s/\"//g; - # s/\A\'(.*?)\'\z/$1/; - } @_; -} - -sub make_tree -{ - my $path = shift; - &norm_path($path); - $path = &rel2abs($path,$curr_dir); - return(0) if -d $path; - my @dirs = &split_path($path); - $path = ''; - foreach(@dirs) - { - $path .= "$_$chr_dirsep"; - unless(-d $path) - { - mkdir($path,0777) or return $error{'cant_mdir'} -> ($path); - } - } - chop $path; - $message ->("Directory '$path' has been created"); - return(0); -} - -sub rel2abs -{ - return $_[0] if $_[0] =~ /$reg_abs/; # is absolute - my @rel = &split_path($_[0]); - my @abs = &split_path($_[1]); - foreach(@rel) - { - next if /\A\.\z/; - if(/\A\.\.\z/) - { - pop(@abs); - next; - } - push(@abs, $_); - } - if(@abs) - { - return &join_path(@abs); - } - else - { - @abs = &split_path($_[1]); # just drive - return $abs[0]; - } -} - -# system command - -sub sys -{ - system(&join_list(@_)); - return $?; -} - -sub set -{ - my ($key, $val); - while($key = shift @_) - { - if($key =~ /=/) - { - ($key, $val) = split("=",$key); - } - else - { - $val = shift(@_); - } - unless($key eq '') - { - $ENV{$key} = $val; - } - } -} - -# messaging - -$message_prefix = '% '; -$warning_prefix = '! '; -$messdbg_prefix = '? '; - -$_message = sub {return "$message_prefix$_[0]\n"}; -$_warning = sub {return "$warning_prefix$_[0]\n"}; -$_messdbg = sub {return "$messdbg_prefix$_[0]\n"}; - -# printing to non-existing handle produce 'Bad file descriptor' error; -# we don't have fork so printing to log and terminal needs to be parallel; -# because of somewhat weird STRERR behaviour under windows, everything is -# printed to STDOUT (for tlpmgui) or to file; -# later we throw progress information to STRERR while installing from DVD - -sub _mess {print @_} -sub _logmess {print @_;print LOG @_} - -sub _messf{printf @_} -sub _logmessf {printf @_;printf LOG @_} - -sub _message -{ - print STDOUT $_message -> (@_); -} - -sub _logmessage -{ - print STDOUT $_message -> (@_); - print LOG $_message -> (@_); -} - -sub _warning -{ - print STDOUT $_warning -> (@_); -} - -sub _logwarning -{ - print STDOUT $_warning -> (@_); - print LOG $_warning -> (@_); -}; - -sub talk2log -{ - $mess = \&_logmess; - $messf = \&_logmessf; - $message = \&_logmessage; - $warning = \&_logwarning; -} - -sub not2log -{ - $mess = \&_mess; - $messf = \&_messf; - $message = \&_message; - $warning = \&_warning; -} - -sub enable_dbg -{ - $debug_mode = 1; - $messdbg = sub {print STDOUT $_messdbg -> (@_)} -} - -sub disable_dbg -{ - $debug_mode = 0; - $messdbg = \&relax -} - -# -) - -sub relax -{ - return; # not zero! -} - -# singular vs plural - -sub one_or_more -{ - return $_[0] . ' ' . ($_[0] == 1 ? $_[1] : $_[2]); -} - -# ...meybe someday we will use returned error codes -# errcode 0 is ok, 1 is help, negative means something went wrong - -%error = -( - 'tl_not_found' => sub {$warning -> ("TeX Live CD/DVD not found"); -1}, - 'not_tl_source' => sub {$warning -> ("TeX Live source not found at '$_[0]'"); -1}, - 'cant_odir' => sub {$warning -> ("Can't open directory '$_[0]'"); -2}, - 'cant_mdir' => sub {$warning -> ("Can't create directory '$_[0]'"); -3}, -# 'cant_wdir' => sub {$warning -> ("Directory '$_[0]' is not writable"); ?}, -# 'dir_unspec' => sub {$warning -> ("Target directory unspecified"); ?}, -# 'file_not_found' => sub {$warning -> ("Can't find file '$_[0]'"); ?}, - 'miss_dir' => sub {$warning -> ("Directory '$_[0]' does not exist"); -4}, - 'empty_dir' => sub {$warning -> ("Directory '$_[0]' contains no packages"); -5}, - 'wrong_out' => sub {$warning -> ("Can't write to '$_[0]'"); -6}, - 'wrong_inp' => sub {$warning -> ("Can't read from '$_[0]'"); -7}, - 'pkg_unspec' => sub {$warning -> ("Package unspecified"); -8}, - 'pkg_not_inst' => sub {$warning -> ("Package '$_[0]' is not installed"); -9}, - 'pkg_not_found' => sub {$warning -> ("Can't find package '$_[0]'"); -10}, - 'not_found' => sub {$warning -> ("Can't find '$_[0]'"); -11}, - 'wrong_opt' => sub {$warning -> ("Unknown option '$_[0]'. Type '$_[1]'"); -12}, - 'wrong_cmd' => sub {$warning -> ("Unknown command '$_[0]'. Type '$_[1]'"); -13}, - 'wrong_syn' => sub {$warning -> ("Incorrect phrase '$_[0]'"); -14}, - 'wrong_reg' => sub {$warning -> ("Incorrect expression '$_[0]'"); -15}, -# 'not_supp' => sub {$warning -> ("Sorry, $_[0] not yet supported"); -16} -); - -# date handling - -sub date -{ - my ($min,$hr,$day,$mon,$year) = (localtime)[1,2,3,4,5]; - $year += 1900; - ($min,$hr,$day,$mon) = map {sprintf "%02d",$_} ($min,$hr,$day,$mon + 1); - return "$day.$mon.$year, $hr:$min"; -} - -# quoting - -sub doubleq {return '"' . $_[0] . '"'} -sub singleq {return "'" . $_[0] . "'"} - -# progress - -sub percent -{ - return sprintf("%d%%",$_[0]*100/$_[1]); -} - -1; |