# This file belongs to TLPM v2.14, 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 # trivial 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 $?; } # messaging $message_prefix = '% '; $warning_prefix = '! '; $_message = sub {return "$message_prefix$_[0]\n"}; $_warning = sub {return "$warning_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; } ¬2log(); # 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]); } # -) sub relax { return; # not zero } 1;