home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / FAQ / discus_admin_1357211388 / source / authpass.pl < prev    next >
Text File  |  2009-11-06  |  18KB  |  554 lines
  1. # FILE: authpass.pl
  2. # DESCRIPTION: Authentication routines & read account files
  3. #-------------------------------------------------------------------------------
  4. # DISCUS COPYRIGHT NOTICE
  5. #
  6. # Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
  7. # The use of Discus is governed by the Discus License Agreement which is
  8. # available from the Discus WWW site at:
  9. #    http://www.discusware.com/discus/license
  10. #
  11. # Pursuant to the Discus License Agreement, this copyright notice may not be
  12. # removed or altered in any way.
  13. #-------------------------------------------------------------------------------
  14.  
  15. use strict;
  16. use vars qw($GLOBAL_OPTIONS $DCONF $PARAMS);
  17.  
  18. ###
  19. ### check_password
  20. ###
  21. ### Checks a moderator or user's password against the database.  Default operation
  22. ### is to update the "last access" time but not the "last search" time.  Control
  23. ### these through $args->{silent} and $args->{new_message}, respectively.
  24. ###
  25.  
  26. sub check_password {
  27.     my ($username, $guess, $args, $cookies) = @_;
  28.     my $suspended = 0;
  29.     $username = prepare_userpass($username);
  30.     $guess = prepare_userpass_p($guess);
  31.     my @result = ();
  32.     return \@result if $username eq "";
  33.     my $file = "passwd,users";
  34.     $file = "passwd" if $args->{type_required} eq "moderator";
  35.     $file = "users" if $args->{type_required} eq "user";
  36.     performance_string("NOTE: Authentication of [$username :: $file] at check_password") if $GLOBAL_OPTIONS->{performance_monitoring};
  37.     my $new_message = (defined $args->{new_message} ? 1 : 0);
  38.     $new_message = 0 if defined $args->{silent};
  39.     my $timecache = time;
  40.     $username = $args->{authenticated} if $username eq "";
  41.     my $fast_update = 1;
  42.     if ($PARAMS->{'emergency_access'} && -e "$DCONF->{admin_dir}/data/emergency-fail.txt" && $DCONF->{superuser} eq $username) {
  43.         dreq("emergpw");
  44.         my $x = validate_emergency_password($guess, $cookies, $args);
  45.         if ($x ne "") {
  46.             $GLOBAL_OPTIONS->{database} = 0;
  47.             return [ { database => 'passwd', user => $username, pass => $x } ];    
  48.         }
  49.     }    
  50.     $GLOBAL_OPTIONS->{u_last_access_info} = 0 if ($DCONF->{pro} && $GLOBAL_OPTIONS->{database} == 1);
  51.     $fast_update = 0 if ($guess eq "" && $GLOBAL_OPTIONS->{u_last_access_info} >= 1);
  52.     $fast_update = 0 if ($cookies->{uid} ne "" && $GLOBAL_OPTIONS->{u_last_access_info} >= 2);
  53.     $fast_update = 0 if ($new_message == 0 && $GLOBAL_OPTIONS->{u_last_access_info} >= 3);
  54.     $fast_update = 1 if $new_message;
  55.     $fast_update = 0 if ($args->{no_record} == 1);
  56.     my ($u, $f);
  57.     if ($PARAMS->{'emergency_access'}) {
  58.         open (OUT, "> $DCONF->{admin_dir}/data/emergency-fail.txt");
  59.         close (OUT);
  60.     }    
  61.     if ($fast_update) {
  62.         ($u, $f) = read_account_file($file, { $username => 1 }, { authenticate_password => 1, update_time => 1 - $args->{silent}, new_message => $args->{new_message}, no_lock => (1 - $fast_update), no_unlock => $fast_update, dbh => $args->{dbh}, fast_update => $fast_update });
  63.     } else {
  64.         ($u, $f) = read_account_file($file, { $username => 1 }, { update_time => 1 - $args->{silent}, new_message => $args->{new_message}, no_lock => 1, no_unlock => 1, dbh => $args->{dbh}, fast_update => 0 });
  65.     }
  66.     if ($PARAMS->{'emergency_access'}) {
  67.         unlink "$DCONF->{admin_dir}/data/emergency-fail.txt";
  68.     }
  69.     my $expired = 0;
  70.     foreach my $x (@{ $u->{$username} }) {
  71.         my $ok = 0;
  72.         if ($args->{authenticated} eq $username) {
  73.             $ok = 0;
  74.         } else {
  75.             my $pass = $x->{'pass'};
  76.             if ($pass =~ /^\*.*?\|\|([^\*].*)$/) {
  77.                 $pass = $1;
  78.             } elsif ($pass =~ m%^(.*?)\|\|(.*)$%) {
  79.                 my ($actual_pass, $temp_pass) = ($1, $2);
  80.                 $pass = $actual_pass;
  81.                 $pass = $' if $pass =~ m|^\*|;
  82.             }
  83.             $ok = 1 if crypt($guess, $pass) eq $pass;
  84.             $ok = 0 if $pass eq "";
  85.             $ok = 1 if $username eq $DCONF->{superuser} && $pass eq "" && $guess eq "" && $args->{blank_ok};
  86.             if ($ok == 0 && $cookies->{pass} eq crypt($pass, "cookie") && ($guess eq "" || $guess eq "adminlogin")) {
  87.                 $ok = 1;
  88.                 if ($GLOBAL_OPTIONS->{mod_session_expire_inactivity} > 0 && $GLOBAL_OPTIONS->{mod_session_expire}) {
  89.                     if (60*$GLOBAL_OPTIONS->{mod_session_expire_inactivity} < ($timecache - $x->{atime})) {
  90.                         $expired = 1; $ok = 0;
  91.                     }
  92.                 }
  93.             }
  94.             $ok = 0 if $guess ne "" && $pass eq "";
  95.             $ok = 1 if $cookies->{cpwd} eq crypt($pass, "cookie") && ! $args->{nocookies} && ($guess eq "" || $guess eq "adminlogin" || $guess =~ /^x+$/);
  96.             $ok = 0 if $pass eq "" && $username ne $DCONF->{superuser};
  97.             if ($PARAMS->{'emergency_access'} && $DCONF->{superuser} eq $username) {
  98.                 dreq("emergpw");
  99.                 my $xy = validate_emergency_password($guess, $cookies, $args);
  100.                 if ($xy ne "") {
  101.                     $ok = 1;
  102.                     $x->{pass} = $xy;
  103.                 }
  104.             }    
  105.             if ($ok == 1 && $x->{pass} =~ m|^\*|) {
  106.                 if ($DCONF->{pro} && ! $args->{no_dump} && $x->{pass} =~ m%^(.*?)\|\|(.*)%) {
  107.                     my ($actual_pass, $temp_pass) = ($1, $2);
  108.                     if ($actual_pass =~ m|^\*|) {
  109.                         my @u = split(/,/, $file);
  110.                         foreach my $u (@u) {
  111.                             unlock("$DCONF->{admin_dir}/$u.txt");
  112.                         }
  113.                         return (\@result, $x, $guess) if $args->{no_suspend};
  114.                         dreq("suspend-PRO");
  115.                         suspended_account($x, $guess);
  116.                     }
  117.                 }
  118.             }
  119.             $ok = 0 if ($cookies->{access} && ! $args->{skip_naughtyboy_cookie});
  120.         }
  121.         if ($ok == 1) {
  122.             push (@result, \%{$x});
  123.             fastupdate_account_file($f, $x->{user}, { database => $x->{database}, timecache => $timecache, new_message => $new_message, dbh => $args->{dbh} }) if $fast_update;
  124.         }
  125.     }
  126.     if ($fast_update) {
  127.         if ($GLOBAL_OPTIONS->{database} == 0 || ! $DCONF->{pro}) {
  128.             fastupdate_kill($f);
  129.         } else {
  130.             dreq("sql-acct-PRO");
  131.             sql_fast_update(\@result, { update_time => 1 - $args->{silent}, new_message => $args->{new_message}, no_lock => (1 - $fast_update), no_unlock => $fast_update, dbh => $args->{dbh}, fast_update => $fast_update });
  132.         }
  133.     }
  134.     if (scalar(@result) == 0 && $expired == 1) {
  135.         dreq("admin-pl");
  136.         bad_login({session_expired => 1});
  137.     }
  138.     return \@result;
  139. }
  140.  
  141. ###
  142. ### condition_match
  143. ###
  144. ### Checks to see if a condition is met
  145. ###
  146.  
  147. sub condition_match {
  148.     my ($rec, $condition) = @_;
  149.     if (defined $condition->{suspend}) {
  150.         my @g = ();
  151.         if (ref $condition->{suspend} eq 'ARRAY') {
  152.             @g = @{$condition->{suspend}};
  153.         } elsif (ref $condition->{suspend} eq 'HASH') {
  154.             @g = keys %{$condition->{suspend}};
  155.         } else {
  156.             @g = ( $condition->{suspend} );
  157.         }
  158.         @g = map { quotemeta($_) } @g;
  159.         foreach my $pat (@g) {
  160.             return 0 if $rec->{pass} !~ m%^\*.*\|\|$pat%;
  161.         }
  162.     }
  163.     if (defined $condition->{nosuspend}) {
  164.         my @g = ();
  165.         if (ref $condition->{nosuspend} eq 'ARRAY') {
  166.             @g = @{$condition->{nosuspend}};
  167.         } elsif (ref $condition->{nosuspend} eq 'HASH') {
  168.             @g = keys %{$condition->{nosuspend}};
  169.         } else {
  170.             @g = ( $condition->{nosuspend} );
  171.         }
  172.         @g = map { quotemeta($_) } @g;
  173.         foreach my $pat (@g) {
  174.             return 0 if $rec->{pass} =~ m%^\*.*\|\|$pat%;
  175.         }
  176.     }
  177.     if (defined $condition->{group}) {
  178.         my @g = ref $condition->{group} eq 'ARRAY' ? @{$condition->{group}} : ($condition->{group});
  179.         my %x = map { $_, 1 } grep { /\S/ } split(/\//, $rec->{groups});
  180.         my $flag = 0;
  181.         foreach my $g (@g) {
  182.             if ($x{$g->{group}} == 1) {
  183.                 $flag = 1; last;
  184.             }
  185.         }
  186.         return 0 if $flag == 0;
  187.     }
  188.     return 1;
  189. }
  190.  
  191. ###
  192. ### grab_fields
  193. ###
  194. ### Gets desired fields from account query
  195. ###
  196.  
  197. sub grab_fields {
  198.     my ($record_in, $param_ref) = @_;
  199.     return $record_in if ref $param_ref->{return_fields} ne 'HASH';
  200.     my %z = map { $_, $record_in->{$_} } keys %{$param_ref->{return_fields}};
  201.     return \%z;
  202. }
  203.  
  204. ###
  205. ### read_account_file
  206. ###
  207. ### Reads in users.txt, passwd.txt, or the database and returns selected users
  208. ### or all users in a convenient format.  Use of this routine to read the user
  209. ### base makes the rest of the functions independent of whether you are using
  210. ### the MySQL back end, flat text files, or separated text files.
  211. ###
  212.  
  213. sub read_account_file {
  214.     my ($database, $username_ref, $param_ref) = @_;
  215.     undef my $result;
  216.     $PARAMS->{dbh} = database_dbh();
  217.     my $fast_update = {};
  218.     $param_ref->{returnformat} = "standard" if $param_ref->{returnformat} eq "";
  219.     if ($GLOBAL_OPTIONS->{database} == 1 && $DCONF->{pro}) {
  220.         dreq("sql-acct-PRO");
  221.         return sql_read_account_file($database, $username_ref, $param_ref);
  222.     } else {
  223.         my @files = ();
  224.         if ($DCONF->{pro} && $GLOBAL_OPTIONS->{split_user_files} && $database =~ m|users|) {
  225.             dreq("userfile-PRO");
  226.             @files = userfile_build_list($database, $username_ref);
  227.         } else {
  228.             my @f = split(/,/, $database);
  229.             foreach my $l (@f) {
  230.                 push (@files, "$DCONF->{admin_dir}/$l.txt");
  231.             }
  232.         }
  233.         foreach my $file (@files) {
  234.             my $data = undef;
  235.             my $tellresult = undef;
  236.             my $db_read = ($file =~ m|passwd| ? "passwd" : "users");
  237.             $data = readfile($file, "read_account_file", { no_lock => $param_ref->{no_lock}, no_unlock => $param_ref->{no_unlock}, zero_ok => 1, create => 1, 'tell' => 0 }) if ! $param_ref->{fast_update};
  238.             ($data, $tellresult) = readfile($file, "read_account_file", { no_unlock => 1, zero_ok => 1, create => 1, 'tell' => 1 }) if $param_ref->{fast_update};
  239.             my $w = 0;
  240. W:            while (my $k = shift @{ $data }) {
  241.                 my @k = split(/:/, $k, 2);
  242.                 next if $k[0] eq "#";
  243.                 my $teller = defined $tellresult ? shift @{ $tellresult } : undef;
  244.                 if (defined $username_ref) {
  245.                     next W if ! $username_ref->{$k[0]};
  246.                 }
  247.                 my $ref = user_line_as_hash($k);
  248.                 next W if $ref->{user} eq "DISABLEANON";
  249.                 next W if $ref->{user} eq "UPDATED300";
  250.                 next W if $ref->{user} eq "PUBLIC";
  251.                 if (defined $param_ref->{condition}) {
  252.                     next W if ! condition_match($ref, $param_ref->{condition});
  253.                 }
  254.                 $ref->{database} = $db_read;
  255.                 push (@{ $result->{ $ref->{user} } }, \%{ $ref }) if $param_ref->{returnformat} eq "standard";
  256.                 $result->{ $ref->{user} } = \%{ $ref } if $param_ref->{returnformat} eq "single_hash";
  257.                 push (@{ $result }, \%{ $ref }) if $param_ref->{returnformat} eq "single_array";
  258.                 if ($param_ref->{fast_update}) {
  259.                     my $l = undef;
  260.                     if (defined $fast_update->{$ref->{user}}->{file}) {
  261.                         if (ref $fast_update->{$ref->{user}}->{file} eq 'ARRAY') {
  262.                             my @i = @{$fast_update->{$ref->{user}}->{file}};
  263.                             push @i, $file;
  264.                             $l->{file} = \@i;
  265.                         } else {
  266.                             my @i = ($fast_update->{$ref->{user}}->{file});
  267.                             push @i, $file;
  268.                             $l->{file} = \@i;
  269.                         }
  270.                     } else {
  271.                         $l->{file} = $file;
  272.                     }
  273.                     if (defined $fast_update->{$ref->{user}}->{position}) {
  274.                         if (ref $fast_update->{$ref->{user}}->{position} eq 'ARRAY') {
  275.                             my @i = @{$fast_update->{$ref->{user}}->{position}};
  276.                             push @i, $teller;
  277.                             $l->{position} = \@i;
  278.                         } else {
  279.                             my @i = ($fast_update->{$ref->{user}}->{position});
  280.                             push @i, $teller;
  281.                             $l->{position} = \@i;
  282.                         }
  283.                     } else {
  284.                         $l->{position} = $teller;
  285.                     }
  286.                     if (defined $fast_update->{$ref->{user}}->{uline}) {
  287.                         if (ref $fast_update->{$ref->{user}}->{uline} eq 'ARRAY') {
  288.                             my @i = @{$fast_update->{$ref->{user}}->{uline}};
  289.                             push @i, $k;
  290.                             $l->{uline} = \@i;
  291.                         } else {
  292.                             my @i = ($fast_update->{$ref->{user}}->{uline});
  293.                             push @i, $k;
  294.                             $l->{uline} = \@i;
  295.                         }
  296.                     } else {
  297.                         $l->{uline} = $k;
  298.                     }
  299.                     $fast_update->{$ref->{user}} = $l;
  300.                     $w++;
  301.                 }
  302.             }
  303.             if ($w == 0) {
  304.                 unlock($file) if $param_ref->{fast_update};
  305.             }
  306.         }
  307.         return $result if ! $param_ref->{fast_update};
  308.         return ($result, $fast_update);
  309.     }
  310. }
  311.  
  312. ###
  313. ### user_line_as_hash
  314. ###
  315. ### Converts a line of raw input to a useful, easy manipulated hash
  316. ###
  317.  
  318. sub user_line_as_hash {
  319.     my @r = ();
  320.     my @s = ('user', 'pass', 'email', 'fullname', 'edit', 'notify', 'ctime', 'stime', 'atime', 'groups');
  321.     my $ss = scalar(@s);
  322.     while (my $x = shift) {
  323.         chomp $x;
  324.         my @x = split(/:/, $x, $ss);
  325.         my @stemp = @s;
  326.         undef my $i;
  327.         while (my $s = shift @s) {
  328.             $i->{$s} = shift @x;
  329.             $i->{$s} = "" if $s eq "email" && $i->{$s} eq "email";
  330.             $i->{$s} = "" if $s eq "fullname" && $i->{$s} eq "fullname";
  331.         }
  332.         if ($i->{stime} =~ /\D/) {
  333.             $i->{ip_addr} = $i->{stime}; $i->{stime} = 0;
  334.         }
  335.         if ($i->{atime} =~ /\D/) {
  336.             $i->{ip_host} = $i->{atime}; $i->{atime} = 0;
  337.         }
  338.         $i->{ctime} = $' if $i->{ctime} =~ /.*\D/;
  339.         push (@r, $i);
  340.     }
  341.     return $r[0] if scalar(@r) == 1;
  342.     return \@r;
  343. }
  344.  
  345. ###
  346. ### generate_user_line
  347. ###
  348. ### Inverse of user_line_as_hash; turns a hash into a line to write into users.txt, etc.
  349. ###
  350.  
  351. sub generate_user_line {
  352.     my ($hashref) = @_;
  353.     my @s = ('user', 'pass', 'email', 'fullname', 'edit', 'notify', 'ctime', 'stime', 'atime', 'groups');
  354.     my @r = ();
  355.     foreach my $s (@s) {
  356.         push (@r, $hashref->{$s});
  357.     }
  358.     return join("", join(":", @r), "\n");
  359. }
  360.  
  361. ###
  362. ### prepare_userpass
  363. ###
  364. ### Removes certain non-alphanumeric characters and converts to lower case
  365. ###
  366.  
  367. sub prepare_userpass {
  368.     my @out = ();
  369.     my $z = chr(0);
  370.     my $y = quotemeta(chr(47));
  371.     my $w = quotemeta(chr(58));
  372.     my $v = quotemeta(chr(94));
  373.     my $u = quotemeta(chr(96));
  374.     my $t = quotemeta(chr(123));
  375.     my $s = quotemeta(chr(125));
  376.     while (my $x = shift @_) {
  377.         $x =~ s/^\s+//;
  378.         $x =~ s/\s+$//;
  379.         $x = case_lower($x);
  380.         $x =~ s/\s+/_/g;
  381.         $x =~ s/[$z-$y$w-$v$u$t-$s]//g;
  382.         push (@out, $x);
  383.     }
  384.     return @out if scalar(@out) > 1;
  385.     return $out[0] if scalar(@out) <= 1;
  386. }
  387.  
  388. ###
  389. ### prepare_userpass_p
  390. ###
  391. ### Password version of 'prepare_userpass_p' which recognizes an option
  392. ### to SKIP the conversion of the username to lower-case letters
  393. ###
  394.  
  395. sub prepare_userpass_p {
  396.     my @out = @_;
  397.     if ($GLOBAL_OPTIONS->{password_no_prepare}) {
  398.         return $out[0] if scalar @out <= 1;
  399.         return @out;
  400.     }
  401.     return prepare_userpass(@out);
  402. }
  403.  
  404. ###
  405. ### lpad
  406. ###
  407. ### Pads a string on the left with a given character so that the string will
  408. ### always have the correct length.  Used for fixed-width fields.
  409. ###
  410.  
  411. sub lpad {
  412.     my ($st, $ch, $len) = @_;
  413.     if (length($st) < $len) {
  414.         return join("", $ch x ($len - length($st)), $st);
  415.     } elsif ($len > $ch) {
  416.         return substr($st, 0, $len);
  417.     } else {
  418.         return $st;
  419.     }
  420. }
  421.  
  422. ###
  423. ### userpass_field_dump
  424. ###
  425. ### Names of the fields in the user database
  426. ###
  427.  
  428. sub userpass_field_dump {
  429.     my $string = "user pass email fullname edit notify ctime stime atime groups picture";
  430.     $string .= " prefs favorites signature status posts ";
  431.     for (my $i = 1; $i <= 20; $i++) {
  432.         $string .= "personal$i\n";
  433.     }
  434.     for (my $i = 1; $i <= 10; $i++) {
  435.         $string .= "custom$i\n";
  436.         $string .= "customdesc$i\n";
  437.     }
  438.     my @fields = split(/\s+/, $string);
  439.     @fields = grep(/\S/, @fields);
  440.     return \@fields;
  441. }
  442.  
  443. ###
  444. ### fastupdate_kill
  445. ###
  446. ### Called when there is no more fast updating to be done.
  447. ###
  448.  
  449. sub fastupdate_kill {
  450.     my ($fastupdate) = @_;
  451.     if ($GLOBAL_OPTIONS->{database} == 1 && $DCONF->{pro}) {
  452.         my $dbh = $fastupdate->{dbh};
  453.         return 0 if ! defined $dbh;
  454.         return 1;
  455.     } else {
  456.         my $unlocked = undef;
  457.         foreach my $k (keys(%{ $fastupdate })) {
  458.             my @f = ref $fastupdate->{$k}->{file} eq 'ARRAY' ? @{$fastupdate->{$k}->{file}} : ($fastupdate->{$k}->{file});
  459.             foreach my $fi (@f) {
  460.                 next if $unlocked->{$fi};
  461.                 unlock($fi);
  462.                 $unlocked->{$fi} = 1;
  463.             }
  464.         }
  465.     }
  466. }
  467.  
  468. ###
  469. ### fastupdate_account_file
  470. ###
  471. ### Performs a fast update of the account file to set the last access time of
  472. ### a moderator or user.
  473. ###
  474.  
  475. sub fastupdate_account_file {
  476.     my ($fastupdate, $user, $params) = @_;
  477.     return 0 if $params->{database} eq "";
  478.     return 0 if ($GLOBAL_OPTIONS->{no_update_access_time} && ! $params->{new_message});
  479.     return 0 if ($GLOBAL_OPTIONS->{database} && $DCONF->{pro});
  480.     my $timecache = defined $params->{timecache} ? $params->{timecache} : time;
  481.     if (ref $fastupdate->{$user}->{file} eq 'ARRAY') {
  482.         my @fi = @{ $fastupdate->{$user}->{file} };
  483.         my @ul = @{ $fastupdate->{$user}->{uline} };
  484.         my @ps = @{ $fastupdate->{$user}->{position} };
  485.         foreach my $fi (@fi) {
  486.             my $o = {};
  487.             $o->{file} = $fi;
  488.             $o->{uline} = shift @ul;
  489.             $o->{position} = shift @ps;
  490.             next if $fi =~ /users\.txt/ && $params->{database} ne "users";
  491.             next if $fi =~ /passwd\.txt/ && $params->{database} ne "passwd";
  492.             _fastupd($fi, $o, $timecache, $params);
  493.         }
  494.     } else {
  495.         _fastupd($fastupdate->{$user}->{file}, $fastupdate->{$user}, $timecache, $params);
  496.     }
  497. }
  498.  
  499. sub _fastupd {
  500.     my ($fi, $fu, $timecache, $params) = @_;
  501.     my $ref = user_line_as_hash($fu->{uline});
  502.     $ref->{atime} = lpad($timecache, "0", 10);
  503.     $ref->{stime} = lpad($timecache, "0", 10) if $params->{new_message};
  504.     my $linenew = generate_user_line($ref);
  505.     if (length $fu->{uline} == length $linenew && can_seek_tell()) {
  506.         sysopen FASTUPDATE, $fi, 2;
  507.         seek FASTUPDATE, $fu->{position}, 0;
  508.         syswrite FASTUPDATE, $linenew, length($linenew);
  509.         close FASTUPDATE;
  510.     } else {
  511.         $ref->{action} = "update";
  512.         dreq("fcn-acct");
  513.         write_account_file($params->{database}, [ $ref ], { fastupdate => 1 });
  514.     }
  515.     performance_string("> fastupdate_account_file for $ref->{user}, $fu->{position}, $fi");
  516.     $PARAMS->{file_access}->{$fi}->{write}++;
  517.     $PARAMS->{files_written}++;
  518.     $PARAMS->{file_access}->{$fi}->{read} += 0;
  519. }
  520.  
  521. ###
  522. ### can_seek_tell
  523. ###
  524. ### Checks to see if the seek/tell routine can be used for fast updates
  525. ### Note (4.00.b26+): due to many problems with this routine, we are disabling
  526. ### it by default.  To enable, add "can_seek_tell=1" to your discus.conf file,
  527. ### without the quotes.
  528. ###
  529.  
  530. sub can_seek_tell {
  531.     return 0 if ! defined $DCONF->{can_seek_tell};
  532.     return $DCONF->{can_seek_tell};
  533.  
  534.     return $PARAMS->{can_seek_tell} if defined $PARAMS->{can_seek_tell};
  535.     return $DCONF->{can_seek_tell} if defined $DCONF->{can_seek_tell};
  536.     return 0 if $DCONF->{NT} || $DCONF->{platform} eq "NT";
  537.     return 0 if $^O eq "MSWin32";
  538.     my $checksum = 0;
  539.     foreach my $k (keys %{$DCONF}) {
  540.         $checksum += unpack("%16C*", $DCONF->{$k});
  541.     }
  542.     my $cst = join("_", $checksum, "can_seek_tell");
  543.     if (defined $GLOBAL_OPTIONS->{$cst}) {
  544.         $PARAMS->{can_seek_tell} = $GLOBAL_OPTIONS->{$cst};
  545.     } else {
  546.         dreq("adm-misc", "adm-opts");
  547.         my $can = test_seek_tell();
  548.         options_save({ $cst => $can });
  549.         $PARAMS->{can_seek_tell} = $can;
  550.     }
  551. }
  552.  
  553. 1;
  554.