# This file belongs to TLPM v2.16, TeX Live Package Manager # Public Domain, P.Jackowski@gust.org.pl # reading packages (internal functions) # here the main work starts %source_packages; # read only once (constant) %target_packages; # read each time is requested (affected by installing / uninstalling) $source_pkges = \%source_packages; $target_pkges = \%target_packages; sub read_pkges # used for reading both source and target packages { my ($dir,$pkges) = @_; # # StaW reports that the condition alike '-d E:' doesn't work in some cases. # Not reproduced... However, '-d E:\texmf' works fine, so unless(-d $dir || -d "$dir$tl_texmf") { return $error{'miss_dir'} -> ($dir); } $dir .= $tl_lists; unless(-d $dir) { return $error{'miss_dir'} -> ($dir); } my ($pkg,$fcount,$pcount,$platform); local (*DIR,*INP); $message -> ("Reading packages from '$dir'..."); opendir(DIR,$dir) or return $error{'cant_odir'} -> ($dir); readdir DIR; readdir DIR; # remove '.' and '..'; dirty but works and make things a bit faster foreach $pkg (readdir DIR) { ($pcount,$fcount) = (0,0); if($pkg =~ /$reg_binary/) { $platform = $1; if($platform =~ s/\A\.//) # bin-. { unless(defined $tl_binaries{$platform}){next} } else # bin- { foreach(keys %tl_binaries) # binaries are not linked by tmps { $pkges -> {$pkg}{'requires'}{"$pkg.$_"} = ++$pcount; } } } elsif($pkg =~ /$reg_library/) { $platform = $1; if($platform =~ s/\A\.//) # only win32? { unless(defined $tl_binaries{$platform}){next} } else { $platform = 'win32'; if(defined $tl_binaries{$platform}) { $pkges -> {$pkg}{'requires'}{"$pkg.$platform"} = ++$pcount; } } } open(INP,"<$dir$chr_dirsep$pkg") or next; foreach() { chomp; if(s/$reg_require//) { $pkges -> {$pkg}{'requires'}{$_} = ++$pcount; } elsif(/$reg_about|$reg_action|$reg_empty/){} else { $pkges -> {$pkg}{'contains'}{&dirsep2dirsep($_)} = ++$fcount; } } close INP; } return $error{'empty_dir'} -> ($dir) unless keys %$pkges; &find_missing($pkges); # not all bin-packages binaries for all platforms closedir DIR; return(0); } sub find_missing { my $pkges = shift; my $pkg; foreach $pkg (&get_pkg_all($pkges)) { foreach(&get_pkg_requires($pkg,$pkges)) { unless(exists $pkges -> {$_}) { $pkges -> {$pkg}{'missing'}{$_} = $pkges -> {$pkg}{'requires'}{$_}; delete $pkges -> {$pkg}{'requires'}{$_}; } } } } sub get_pkg_miss { my ($pkg,$pkges) = @_; return sort keys %{$pkges -> {$pkg}{'missing'}}; } sub read_source { my $err; if($err = &set_source()){return $err} return(0) if %$source_pkges; # read once per session $err = &read_pkges($tl_source,$source_pkges); &undef_source if $err; return $err; } sub read_target { &set_target(); return(0) if %$target_pkges; # read once per session (except if forced) return &read_pkges($tl_target,$target_pkges); } sub set_source { return(0) if $tl_source_indeed; $message -> ("Looking for TeX Live source..."); if(defined $tl_source) # firt check if predefined one is TL source indeed { if(&is_tl_root($tl_source)) { return(0); } else { $error{'not_tl_source'} -> ($tl_source); } } foreach($parent_dir,$curr_dir) # in case TLPM located on CD or DVD { if(&is_tl_root($_)){return(0)} } if($win32) # sorry, no heuristic for others { foreach(D..Z) { if(&is_tl_root("$_:")){return(0)} } unless($batch_mode) # the last chance is prompt { print STDOUT "TeX Live source drive: "; $tl_source = ;chomp $tl_source; if(&is_tl_root($tl_source)) { return(0); } else { $error{'not_tl_source'} -> ($tl_source); } } } else { unless($batch_mode) { print STDOUT "TeX Live source mounting point: "; $tl_source = ;chomp $tl_source; if(&is_tl_root($tl_source)) { return(0); } else { $error{'not_tl_source'} -> ($tl_source); } } } &undef_source(); # not found anyhow -> reset presets return $error{'tl_not_found'} -> (); } sub is_tl_root { my $dir = shift; foreach(@tl_roots) { next if &no_source($dir . $_); $message -> ("Welcome to TeX Live $tl_year $tl_type!"); return $true; } return $false; } sub no_source # strongly heuristic { my $dir = shift; &norm_path($dir); $dir = &rel2abs($dir); if(-f "$dir$chr_dirsep.mkisofsrc") { if(-f "$dir$chr_dirsep" . "00INST.TL") { $tl_type = 'CD'; $tl_file = '00INST.TL'; } elsif(-f "$dir$chr_dirsep" . "00LIVE.TL") { $tl_type = 'DVD'; $tl_file = '00LIVE.TL'; } else { return $true; } $tl_source = $dir; $tl_source_indeed = $true; local *INP; open(INP,"<$dir$chr_dirsep$tl_file") or return $error{'wrong_inp'} -> ($tl_file); my @lines = ; close INP; foreach(@lines) { next unless /\ARelease date: (\d{8}\.)/; $tl_date = $1; # meybe we will use it $tl_year = substr($tl_date,0,4); return $false; } } return $true; } # in opposite to source packages, target is read whenever requested sub set_target { if($tl_target_indeed and $tl_target_new eq ''){return 0} # target defined and not provided in cmdline if($tl_target_new ne '') { &undef_target(); $tl_target = $tl_target_new; $tl_target_new = undef; } my $msg = 'TeX Live installation root directory'; if($tl_target eq '') { if($batch_mode) { $tl_target = $curr_dir; # hm... what shall we do? } else # prompt for target directory { print STDOUT ('Type ' . $msg . ': '); $tl_target = ; &set_target_(); } } else { &set_target_(); } # we tried to test if the directory is writable, but even CD drive respond to be writable... #unless(-w $tl_target) #{ # &undef_target(); # return $error{'cant_wdir'} -> ($tl_target); #} $message -> ($msg . ' set to ' . &singleq($tl_target)); return(0); } sub set_target_ { &norm_path($tl_target); $tl_target = &rel2abs($tl_target,$curr_dir); $tl_target_indeed = $true; } sub undef_source { %source_packages = (); $tl_source = undef; $tl_source_indeed = $false; } sub undef_target { %target_packages = (); $tl_target = undef; $tl_target_indeed = $false; } # some operations on loaded packages stored in hashes sub get_pkg_all { my $pkges = shift; return sort keys %$pkges; } sub get_file_all { my $pkges = shift; return map {sort keys %{$pkges -> {$_}{'contains'}}} &get_pkg_all($pkges); } sub get_pkg_requires { my ($pkg,$pkges) = @_; return sort { $pkges -> {$pkg}{'requires'}{$a} <=> $pkges -> {$pkg}{'requires'}{$b} } keys %{$pkges -> {$pkg}{'requires'}}; } sub get_pkg_requires_all { my ($pkg,$pkges) = @_; local (%trace,@trace); local $level = 0; &get_pkg_requires_recurse($pkg,$pkges); # delete $trace{$pkg}; # package never requires itself shift @trace; return @trace; } sub get_pkg_requires_recurse { my ($pkg,$pkges) = @_; return(0) if exists $trace{$pkg}; #++$level; $trace{$pkg} = $true; push(@trace,$pkg); foreach(&get_pkg_requires($pkg,$pkges)) { &get_pkg_requires_recurse($_,$pkges); } #--$level; } sub get_pkg_contains { my ($pkg,$pkges) = @_; return sort keys %{$pkges -> {$pkg}{'contains'}}; } sub get_pkg_contains_all # assuming each file belongs to ONE package! { my ($pkg,$pkges) = @_; return ( &get_pkg_contains($pkg,$pkges), map {&get_pkg_contains($_,$pkges)} &get_pkg_requires_all($pkg,$pkges) ); } sub get_pkg_belongs { my ($pkg,$pkges) = @_; my ($key, @arr); foreach $key (&get_pkg_all($pkges)) { foreach(&get_pkg_requires($key,$pkges)) { if($_ eq $pkg) { push(@arr,$key); } } } return @arr; } # no longer used #sub is_required #{ # my $pkg = shift; # my $key; # foreach $key (&get_pkg_all($target_pkges)) # { # foreach (&get_pkg_requires($key,$target_pkges)) # { # return 1 if $_ eq $pkg; # } # } # return 0; #} sub get_file_belongs { my $file = quotemeta(shift @_); my $pkges = shift; $file = qr/$reg_dirsep$file\z/i; my ($key,@arr); foreach $key (&get_pkg_all($pkges)) { foreach(&get_pkg_contains($key,$pkges)) { if($_ =~ /$file/) { push @arr, $key; } } } return @arr; } sub is_pkg { my ($pkg,$pkges) = @_; return $true if exists $pkges -> {$pkg}; return $false } sub is_file { my ($file,$pkges) = @_; $file = quotemeta($file); $file = qr/$reg_dirsep$file\z/i; foreach(&get_file_all($pkges)) { return $true if /$file/; } return $false; } # searching for tpm file to show info sub get_tpm { my $pkg = shift; my $file; if(defined $tl_target) { if($file = &get_tpm_($tl_target,$pkg)) { return $file; } } return('') if &set_source(); if($file = &get_tpm_($tl_source,$pkg)) { return $file; } return(''); } sub get_tpm_ { my ($dir,$pkg) = @_; my $file; foreach(@tl_tpms) { $file = "$dir$_$chr_dirsep$pkg.tpm"; if(-f $file) { return $file; } } return ''; } 1;