home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / dictionaries-common / dc-debconf-default-value.pl next >
Encoding:
Text File  |  2011-01-12  |  15.6 KB  |  441 lines
  1. # ----------------------------------------------------------------------------
  2. # dc-debconf-default-value.pl:
  3. #  Dealing with default value selection. Functions and definitions.
  4. # ----------------------------------------------------------------------------
  5.  
  6. # Trying to find a reasonable guess for default ispell dictionary and wordlist
  7. # from the debian-installer settings, envvars or pre-policy symlinks and the
  8. # list of ispell dictionaries and wordlists to be installed
  9.  
  10. $priority{"ispell"}   = "critical"; # These will be changed later,
  11. $priority{"wordlist"} = "critical"; # Do not change value here.
  12. $dcscript             = "/usr/share/dictionaries-common/dc-debconf-select.pl";
  13. $fromdcconfig         = "yes";
  14. $debug                = "yes" if exists $ENV{'DICT_COMMON_DEBUG'};
  15.  
  16.  
  17. my %debconf_vals = ();
  18. my @suffixes     = ("","-large","-medium","-small","-gut");
  19. my %equivs       = ("bg"      => "bulgarian",
  20.             "ca"      => "catalan",
  21.             "cs"      => "czech",
  22.             "da"      => "danish",
  23.             "de"      => "ngerman",
  24.             "de:1"    => "ogerman",
  25.             "de_CH"   => "swiss",
  26.             "en_US"   => "american",
  27.             "en_US:1" => "miscfiles",
  28.             "en_CA"   => "canadian",
  29.             "en_CA:1" => "american",
  30.             "en_GB"   => "british",
  31.             "en_AU"   => "british",
  32.             "eo"      => "esperanto",
  33.             "es"      => "spanish",
  34.             "fi"      => "finnish",
  35.             "fo"      => "faroese",
  36.             "fr"      => "french",
  37.             "ga"      => "irish",
  38.             "gd"      => "gaelic",
  39.             "gl"      => "galician-minimos",
  40.             "gv"      => "manx",
  41.             "hu"      => "hungarian",
  42.             "it"      => "italian",
  43.             "lt"      => "lithuanian",
  44.             "nb"      => "norwegian->bokma",    # Match bokmal and bokmaal
  45.             "nl"      => "dutch",
  46.             "nn"      => "norwegian->nynorsk",
  47.             "pl"      => "polish",
  48.             "pt"      => "portuguese",
  49.             "pt_BR"   => "brazilian",
  50.             "ru"      => "russian",
  51.             "sv"      => "swedish",
  52.             "tl"      => "tagalog",
  53.             "uk"      => "ukrainian");
  54. my %pending_keys   = ();
  55. my %alternatives   = ("ispell"   => "ispell-dictionary.hash",
  56.               "wordlist" => "dictionary");
  57.  
  58. # -------------------------------------------------------------
  59. sub dc_debugprint(){
  60. # -------------------------------------------------------------
  61. # Show info if in debug mode
  62. # -------------------------------------------------------------
  63.   print STDERR "@_" if $debug;
  64. }
  65.  
  66. # -------------------------------------------------------------
  67. sub dc_set (){
  68. # -------------------------------------------------------------
  69. # Set debconf value unless already set
  70. # -------------------------------------------------------------
  71.   my $question  = shift;
  72.   my $value     = shift;
  73.   my $priority  = $priority{$class} || "";
  74.  
  75.   my ($errorcode, $oldvalue) = get($question);
  76.  
  77.   $oldvalue = "unset" unless $oldvalue;
  78.  
  79.   if ( $errorcode or $oldvalue eq "unset" ){
  80.     &dc_debugprint(" $question: errorcode: $errorcode; priority: $priority\n" .
  81.            " Old:[$oldvalue] --> New:[$value]\n");
  82.     set("$question","$value");
  83.   } elsif ( $oldvalue eq $value ) {
  84.     print STDERR "Info: $question is already set to
  85.       [$oldvalue]. Preserving it.\n";
  86.   } else {
  87.     print STDERR "Warning: $question is already set to
  88.       [$oldvalue].
  89.       Not setting to [$value]\n";
  90.   }
  91.  
  92.   if ( $debug ){                 # --- Check if question value is actually set
  93.     ($errorcode, $oldvalue) = get($question);
  94.     if ( $errorcode ){
  95.       print STDERR " dictionaries-common: $question reading failed with $errorcode\n";
  96.     } elsif ( $oldvalue) {
  97.       print STDERR " dictionaries-common: $question actually set to [$oldvalue]\n";
  98.     } else {
  99.       print STDERR " dictionaries-common: $question value is void, bad thing\n";
  100.     }
  101.   }
  102.   &dc_debugprint ("Not tried: " . join(', ',sort keys %pending_keys) . "\n");
  103. }
  104.  
  105. # -------------------------------------------------------------
  106. sub dc_extractlangname (){
  107. # -------------------------------------------------------------
  108. # Look if a dict matching $langkey in %equivs is to be installed
  109. # and return the preferred language name if so.
  110. # -------------------------------------------------------------
  111.   my $langkey     = shift;
  112.   my $classprefix = shift;
  113.   my $thestring   = '';
  114.   my $thepackage  = '';
  115.   my $thevariant  = '';
  116.   my @thevalues   = ();
  117.  
  118.   if ( exists $pending_keys{$langkey} ){ # Make sure we do not try it again
  119.     &dc_debugprint("Trying langkey \"$langkey\" with classprefix \"$classprefix\"\n");
  120.     delete $pending_keys{$langkey};
  121.   } else {
  122.     if ( exists $equivs{$langkey} ){
  123.       # This $langkey was already tried, no need to try it again
  124.       &dc_debugprint("Already done langkey $langkey\n");
  125.     } else {
  126.       # This $langkey does not exist
  127.       &dc_debugprint("Non-existant langkey $langkey\n");
  128.     }
  129.     return;
  130.   }
  131.  
  132.   if ( exists $equivs{$langkey} ){
  133.     ($thepackage,$thevariant) = split ("->",$equivs{$langkey});
  134.     foreach $suffix ( @suffixes ){
  135.       if ( $thepackage eq "miscfiles" ){
  136.     $pkgfullname = "$thepackage$suffix";
  137.       } else {
  138.     $pkgfullname = "$classprefix$thepackage$suffix";
  139.       }
  140.       &dc_debugprint(" Trying package $pkgfullname\n");
  141.       if ( exists $debconf_vals{"$pkgfullname"} ){
  142.     if ( exists $debconf_defaultvals{"$pkgfullname"} ){
  143.       $thestring = $debconf_defaultvals{"$pkgfullname"};
  144.     } else {
  145.       $thestring = $debconf_vals{"$pkgfullname"};
  146.     }
  147.     @thevalues = sort split (/\s*,\s*/,$thestring);
  148.     if ( $thevariant ){
  149.       @thevalues = grep {/$thevariant/i} @thevalues;
  150.     }
  151.     @thevalues = sort {
  152.       $a =~ m/tex/i <=> $b =~ m/tex/i # Sort tex variants last
  153.         ||
  154.       $a cmp $b } @thevalues;
  155.     if ( scalar @thevalues >= 1 ){
  156.       return "$thevalues[0]";
  157.     } else {
  158.       return;
  159.     }
  160.       }
  161.     }
  162.   }
  163. }
  164.  
  165. # -------------------------------------------------------------
  166. sub dc_guesslang (){
  167. # -------------------------------------------------------------
  168. # Try different combinations of $language and $country and possible
  169. # fallbacks in case dc_extractlangname() does not find a good guess
  170. # -------------------------------------------------------------
  171.   my $class              = shift;
  172.   my $language           = shift;
  173.   my $country            = shift;
  174.   my $guessed            = '';
  175.   my @possible_fallbacks = ();
  176.   my $classprefix        = substr($class,0,1);
  177.   my $msgprefix          = "dict-common->dc_guesslang";
  178.  
  179.   &dc_debugprint("$msgprefix: Looking for langkey matches [$class,$classprefix,$language,$country].\n");
  180.   if ( $guessed = &dc_extractlangname("$language" . "_" . uc($country),$classprefix)
  181.        || &dc_extractlangname("$language" . "_" . uc("$country") . ":1",$classprefix)
  182.        || &dc_extractlangname("$language",$classprefix)
  183.        || &dc_extractlangname("$language:1",$classprefix)
  184.     ){
  185.     $priority{$class} = "low";
  186.     return $guessed;
  187.   } else {
  188.     @possible_fallbacks = grep {/$language\_/} sort keys %equivs;
  189.     $priority{$class} = "medium";
  190.     foreach ( @possible_fallbacks ){
  191.       return $guessed if ( $guessed = &dc_extractlangname($_,$classprefix));
  192.     }
  193.     $priority{$class} = "high";
  194.     return;
  195.   }
  196. }
  197.  
  198. # -------------------------------------------------------------
  199. sub dc_guessotherlang (){
  200. # -------------------------------------------------------------
  201. # Iterate over the not yet tried $langkey values for a dict to be
  202. # installed. Return first match
  203. # -------------------------------------------------------------
  204.   my $guessed = '';
  205.  
  206.   foreach ( sort keys %pending_keys ){
  207.     return $guessed if ( $guessed = &dc_extractlangname($_));
  208.   }
  209. }
  210.  
  211. # -------------------------------------------------------------
  212. sub dc_guess_langkey_for_link(){
  213. # -------------------------------------------------------------
  214. # Try guessing langkey after (woody or older) former symlink
  215. # -------------------------------------------------------------
  216.   my $class      = shift;
  217.   my $prefix     = '';
  218.   my $guess      = '';
  219.   my $language   = '';
  220.   my $link       = "/etc/alternatives/$alternatives{$class}";
  221.   my %reverse_equivs = ();
  222.  
  223.   return unless ( -l $link );
  224.  
  225.   if ( $guess = readlink($link) ){
  226.     &dc_debugprint("dictionaries-common.config: Found pre-policy link $link->$guess.");
  227.  
  228.     $guess =~ s/\.hash$//;
  229.     $guess =~ s/^.*\///;
  230.     $guess =~ s/(\-\.)(small|medium|large)$//;
  231.     $guess =~ s/\-english$//;
  232.  
  233.     $guess = "norwegian->bokma"   if ($guess eq "bokmσl");
  234.     $guess = "norwegian->nynorsk" if ($guess eq "nynorsk");
  235.     $guess = "ogerman"            if ($guess eq "german");
  236.     $guess = "miscfiles"          if ($guess eq "web2");
  237.     $guess = "danish"             if ($guess eq "dansk");
  238.     $guess = "french"             if ($guess eq "francais");
  239.     $guess = "swedish"            if ($guess eq "svenska");
  240.  
  241.     &dc_debugprint("dictionaries-common.config: pre-policy link target fine tuned to $guess.\n");
  242.  
  243.     # Build reverse equivs
  244.     foreach ( keys %equivs ){
  245.       $reverse_equivs{$equivs{$_}} = $_;
  246.     }
  247.  
  248.     # Check for a match and return langkey if found
  249.     if ( exists $reverse_equivs{$guess} ){
  250.       return $reverse_equivs{$guess};
  251.     } else {
  252.       &dc_debugprint("dictionaries-common.config: No match found for pre-policy symlink $link.\n");
  253.     }
  254.   }
  255. }
  256.  
  257. # -------------------------------------------------------------
  258. sub dc_manual_alternative (){
  259. # -------------------------------------------------------------
  260. # Check if woody (or older) alternative exists and is set to manual
  261. # -------------------------------------------------------------
  262.   my $class  = shift;
  263.   my $file   = "/var/lib/dpkg/alternatives/$alternatives{$class}";
  264.   my $status = '';
  265.  
  266.   if ( -r $file ){
  267.     open(FILE,"< $file") or return;
  268.     $status = <FILE>;
  269.     close FILE;
  270.     $status = "" unless $status;
  271.     chomp $status;
  272.     return "Manual (previous alternative setting)" if ( $status eq "manual" );
  273.   }
  274. }
  275.  
  276. # -------------------------------------------------------------
  277. sub dc_debconf_rebuild (){
  278. # -------------------------------------------------------------
  279. # Gather info from debconf for the (to be) installed packages for class
  280. #   %debconf_vals         : pkg -> languages provided by package
  281. #   %debconf_defaultvals  : pkg -> default language for package
  282. # -------------------------------------------------------------
  283.   my $class = shift;
  284.   return unless $class;
  285.   my $question = "shared/packages-$class";
  286.   my ($errorcode,$pkgowners) = metaget ($question, "owners");
  287.   return if $errorcode;
  288.  
  289.   %debconf_vals = ();
  290.   %debconf_defaultvals = ();
  291.   foreach ( split (/\s*,\s*/,$pkgowners) ){
  292.     #$debconf_vals{$_} = metaget ("$_/languages", "default");
  293.     $debconf_vals{$_} = get ("$_/languages");
  294.     my ($errorcode,$pkgdefaults) = get ("$_/defaults");
  295.     $debconf_defaultvals{$_} = $pkgdefaults if not $errorcode;
  296.   }
  297.   return "ok";
  298. }
  299.  
  300. # -----------------------------------------------------------------
  301. sub dc_guess_language_country_strings (){
  302. # -----------------------------------------------------------------
  303. # Try guessing $language $country pairs
  304. # -----------------------------------------------------------------
  305.   my $class       = shift;
  306.  
  307.   my $di_language = "debian-installer/language";
  308.   my $di_country  = "debian-installer/country";
  309.   my $msgstring   = "dict-common.config->dc_guess_language_country_strings";
  310.  
  311.   my $language;
  312.   my $country;
  313.   my $errorcode;
  314.  
  315.   # First check if we are upgrading from ancient pre-policy setup with
  316.   # symlinks set through alternatives and try guessing a langkey
  317.   if ( $language = &dc_guess_langkey_for_link($class) ){
  318.     &dc_debugprint("$msgstring: Guessed langkey $language from ancient pre-policy symlink.\n");
  319.   } else {
  320.     # If system is already installed use /etc/default/locale contents.
  321.     # Otherwise try looking at debian-installer/language
  322.     if ( -e "/etc/default/locale" ){
  323.       $language = $ENV{'LANG'} if exists $ENV{'LANG'};
  324.     }
  325.     if ( $language ){
  326.       &dc_debugprint("$msgstring: LANG=$language is to be used.\n") if $language;
  327.     } else {
  328.       ($errorcode,$language) = get($di_language);
  329.       $language = '' if $errorcode;
  330.       &dc_debugprint("$msgstring: Debconf gives language \"$language\"\n") if $language;
  331.     }
  332.   }
  333.  
  334.   # Try hard to get a value if nothing was found
  335.   $language = $language ||
  336.     $ENV{'LANG'} ||
  337.     $ENV{'LC_MESSAGES'} ||
  338.     $ENV{'LC_ALL'} ||
  339.     '';
  340.  
  341.   # Get proper $language $country pairs if $language is available.
  342.   if ( $language ){
  343.     $language = "en" if ( $language eq "C" );
  344.     # Deal with de_DE:de_DE@euro:de:en_GB.UTF-8:en like entries
  345.     $language = ( split(":",$language) )[0];
  346.     $language =~ s/[\.@].*$//;                # Remove variant and charset
  347.     ($language,$country) = split("_",$language);
  348.     if ( not $country ){
  349.       ($errorcode,$country) = get($di_country);
  350.       if ( $errorcode or not $country ){
  351.     $country = "unset";
  352.       }
  353.     }
  354.  
  355.     # Make sure there is no leading/trailing whitespace.
  356.     $language =~ s/^\s+//;
  357.     $language =~ s/\s+$//;
  358.     $country  =~ s/^\s+//;
  359.     $country  =~ s/\s+$//;
  360.  
  361.   } else {
  362.     &dc_debugprint("$msgstring: No language candidate found. Defaulting to \"en_UNSET\"\n");
  363.     $language = "en";
  364.     $country  = "UNSET";
  365.   }
  366.   return $language, $country;
  367. }
  368.  
  369. # -----------------------------------------------------------------
  370. sub dc_set_default_value_for_class (){
  371. # -----------------------------------------------------------------
  372. # Try guessing a reasonable default value for given class after
  373. # $language $country pair and set it if found.
  374. # -----------------------------------------------------------------
  375.   my $class       = shift;
  376.   my $guessed;
  377.   my $msgprefix   = "dict-common.config->dc_set_default_value_for_class";
  378.   my $question    = "dictionaries-common/default-$class";
  379.   my $oldlink     = "/etc/alternatives/$alternatives{$class}";
  380.  
  381.   if ( &dc_debconf_rebuild($class) ){
  382.     # Ancient symlinks may be different for different classes,
  383.     my ( $language, $country ) = &dc_guess_language_country_strings($class);
  384.     %pending_keys              = %equivs;
  385.  
  386.     # First try something reasonably close to the lang +country pair
  387.     if ( $guessed = &dc_guesslang($class,$language,$country) ){
  388.       &dc_debugprint("$msgprefix: Guessed value ->($class,$language,$country,$guessed)\n");
  389.     } else {
  390.       if ( $guessed = &dc_guesslang($class,"en","US")   # Try an English variant
  391.        || &dc_guessotherlang ){                     # Try anything
  392.     &dc_debugprint("$msgprefix: Forcing [$guessed] for ($class,$language,$country)\n");
  393.     $priority{$class} = "medium";
  394.       } else {
  395.     # Signal an error. This should never happen, so the critical priority.
  396.     &dc_debugprint("$msgprefix: No good or bad guess found for ($class,$language,$country)\n");
  397.     $priority{$class} = "critical";
  398.       }
  399.     }
  400.  
  401.     # We may have ancient pre-policy alternative based symlinks with
  402.     # alternative set in manual mode or with more dictionaries installed
  403.     # in the same run. This is an upgrade from an ancient setup, we better ask.
  404.     if ( -l $oldlink ){
  405.       if ( &dc_manual_alternative($class) ){
  406.     &dc_debugprint("$msgprefix: Ancient $class alternative was in manual mode. Setting critical priority\n");
  407.     $priority{$class} = "critical";
  408.       } else {
  409.     foreach ( keys %debconf_vals ){
  410.       my $oldpackage = $_;
  411.       next if ( $oldpackage eq "dictionaries-common" );
  412.       $oldpackage = "wenglish" if ( $oldpackage eq "wamerican" );
  413.       # critical priority if exists debconf entry without a
  414.       # previous package installed. This means that besides
  415.       # upgrading, new dicts are being installed.
  416.       if ( not -e "/var/lib/dpkg/info/$oldpackage.list" ){
  417.         $priority{$class} = "critical";
  418.         &dc_debugprint("$msgprefix: New dict [$oldpackage] is to be installed\n");
  419.         last;
  420.       }
  421.     }
  422.       }
  423.     }
  424.  
  425.     # Actually set the value if found
  426.     &dc_set($question,$guessed) if $guessed;
  427.   } else {
  428.     &dc_debugprint("$msgprefix: No elements found for $class\n");
  429.   }
  430.   return $guessed;
  431. }
  432.  
  433. 1;
  434.  
  435. # -----------------------------------------------------------------
  436. # Local Variables:
  437. # perl-indent-level: 2
  438. # coding: iso-8859-1
  439. # End:
  440.  
  441.