1. Perl / Говнокод #21223

    0

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    sub deprecate_marks
    {
        my ($marks, $task) = @_;
        # дополнительное задание -- не уменьшаем оценку
        $_->{days_late} < 0 ? $_->{days_late} = 0 : undef for @$marks;
        $task->{half_life} or return ($marks->[0] || {})->{points};
        my ($dep_points, $prev_points) = (0, 0);
        for my $m (reverse @$marks)
        {
            # Раньше вычиталось dep_points, что приводило к необоснованному завышению оценки.
            # Чтобы не менять старые данные, исправляем ошибку только для новых заданий.
            my $p = $task->{after_marks_fix} > 0 ? $prev_points : $dep_points;
            my $diff = max($m->{points} - $p, 0);
            $prev_points = $m->{points};
            my $dep_coeff = $task->{half_life} / ($m->{days_late} + $task->{half_life});
            $dep_points += $diff * max(($task->{deprecation_limit} || 10) / 100, $dep_coeff);
            $m->{dep_points} = sprintf '%.1f', $dep_points;
        }
        $dep_points;
    }

    Снижение баллов за задания по программированию

    askfail, 21 Сентября 2016

    Комментарии (18)
  2. Perl / Говнокод #20126

    +22

    1. 1
    ((*+*)***)

    Это не новый смайлик, а один из способов задания анонимных функций в perl6. Как вы думаете, что это за функция?

    Bobik, 02 Июня 2016

    Комментарии (118)
  3. Perl / Говнокод #20020

    +15

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    25. 25
    26. 26
    27. 27
    28. 28
    29. 29
    30. 30
    31. 31
    32. 32
    33. 33
    34. 34
    35. 35
    36. 36
    37. 37
    38. 38
    39. 39
    40. 40
    41. 41
    42. 42
    43. 43
    44. 44
    45. 45
    46. 46
    47. 47
    48. 48
    49. 49
    50. 50
    51. 51
    52. 52
    53. 53
    54. 54
    55. 55
    56. 56
    57. 57
    #!/usr/bin/perl -w
    
    use IO::Socket;
    
    @months = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
    
    $server_port = 1488;
    $server = IO::Socket::INET->new(
        LocalPort => $server_port,
        Type => SOCK_STREAM,
        Reuse => 1,
        Listen => 20
    )
    or die "Can\'t use port:$server_port";
    
    while($client_socket = $server->accept()) {
        while ($count = sysread($client_socket, $data, 1024)) {
            print "Принято ${count} байт: ${data}\n";
    
            if ($data eq '/time') {
                ($sec,$min,$hour) = localtime();
                if ($hour < 10) {
                    $hour = "0$hour";
                }
                if ($min < 10) {
                    $min = "0$min";
                }
                if ($sec < 10) {
                    $sec = "0$sec";
                }
                $client_socket->send("$hour:$min:$sec");
            } elsif ($data eq '/date') {
                ($sec,$min,$hour,$mday,$mon,$year) = localtime();
                $year += 1900;
                $client_socket->send("$mday $months[$mon] $year");
            } elsif ($data eq '/datetime') {
                ($sec,$min,$hour,$mday,$mon,$year) = localtime();
                $year += 1900;
                if ($hour < 10) {
                    $hour = "0$hour";
                }
                if ($min < 10) {
                    $min = "0$min";
                }
                if ($sec < 10) {
                    $sec = "0$sec";
                }
                $client_socket->send("$mday $months[$mon] $year $hour:$min:$sec");
            } else {
                $client_socket->send("nil");
            }
        }
    
        shutdown($client_socket, 1);
    }
    
    $server->close();

    Обнаружил сокет-сервер на перел

    ufufney, 16 Мая 2016

    Комментарии (10)
  4. Perl / Говнокод #19952

    +14

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    #!/usr/bin/perl -w
    
    use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
    no warnings 'once';
    require "send_server_header.txt";
    send_server_header("html");
    
    $latest_release = "../programs/sasplanet/SASPlanet_121010.zip";		#ссыль на последний релиз
    
    
    print "<html><head>";
    print "<meta http-equiv=\"Content-type\" content=\"text/html; charset=UTF-8\" />";
    print "<meta http-equiv=\"Pragma\" content=\"no-cache\" />";
    print "<meta http-equiv=\"Cache-Control\" content=\"no-cache\" />";
    print "<meta http-equiv=\"Pragma-directive\" content=\"no-cache\" />";
    print "<meta http-equiv=\"Cache-Directive\" content=\"no-cache\" />";
    print "<meta name=\"robots\" content=\"noindex,follow\" />";
    print "<title>SAS.Планета - файловый архив</title>";
    print "<link href=\"stylesheet.css\" rel=\"stylesheet\" type=\"text/css\" />";
    print "<meta http-equiv=Refresh content=\"10; url=".$latest_release."\">";
    print "</head>";
    
    print "<h2>Последняя стабильная версия:</h2>";

    И ещё 60 строк, содержащих вызов print.

    inkanus-gray, 06 Мая 2016

    Комментарии (82)
  5. Perl / Говнокод #19749

    +15

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    25. 25
    26. 26
    27. 27
    28. 28
    29. 29
    30. 30
    31. 31
    #!/usr/bin/perl5.18
    
    $file = $ARGV[0];
    if (!$file) {
        print "Введите имя файла: ";
        $file = <STDIN>;
        chomp $file;
    }
    $direction = $ARGV[1];
    if (!$direction) {
        print "Введите направление: ";
        $direction = <STDIN>;
        chomp $direction;
    }
    if ($direction ne '866toKOI8' && $direction ne 'KOI8to866') {
        die "Invalid param";
    }
    
    open (IN_FILE, "<$file") or die "Cannot open file";
    open (OUT_FILE, ">out$file") or die "Cannot open file";
    $text = '';
    while (my $row = <IN_FILE>) {
        if ($direction eq '866toKOI8') {
            $row =~ tr/\x80\x81\x82\x83\x84\x85\xF0\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F\xA0\xA1\xA2\xA3\xA4\xA5\xF1\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF/\xE1\xE2\xF7\xE7\xE4\xE5\xB3\xF6\xFA\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF2\xF3\xF4\xF5\xE6\xE8\xE3\xFE\xFB\xFD\xFF\xF9\xF8\xFC\xE0\xF1\xC1\xC2\xD7\xC7\xC4\xC5\xA3\xD6\xDA\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD2\xD3\xD4\xD5\xC6\xC8\xC3\xDE\xDB\xDD\xDF\xD9\xD8\xDC\xC0\xD1/;
        } else {
            $row =~ tr/\xE1\xE2\xF7\xE7\xE4\xE5\xB3\xF6\xFA\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF2\xF3\xF4\xF5\xE6\xE8\xE3\xFE\xFB\xFD\xFF\xF9\xF8\xFC\xE0\xF1\xC1\xC2\xD7\xC7\xC4\xC5\xA3\xD6\xDA\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD2\xD3\xD4\xD5\xC6\xC8\xC3\xDE\xDB\xDD\xDF\xD9\xD8\xDC\xC0\xD1/\x80\x81\x82\x83\x84\x85\xF0\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F\xA0\xA1\xA2\xA3\xA4\xA5\xF1\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF/;
        }
        print OUT_FILE $row;
    }
    close (IN_FILE);
    close (OUT_FILE);

    Смена кодировки из cp866 в KOI8 и обратно. Шел 2016й год.....................

    ufufney, 04 Апреля 2016

    Комментарии (12)
  6. Perl / Говнокод #19597

    +14

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    25. 25
    26. 26
    27. 27
    28. 28
    29. 29
    30. 30
    31. 31
    32. 32
    33. 33
    34. 34
    35. 35
    36. 36
    37. 37
    38. 38
    package Whatever;
    
    use strict;
    use warnings;
    use Data::Dumper;
    
    use constant {
        PASSWORD            => 'password',
        PROFILE             => 'profile',
        ROOT_USER_DN        => 'bind-dn',
    };
    
    sub _export_data {
        my ($self, $data) = @_;
        # внутренняя логика не важна: просто напечатаем что получили
        print Dumper($data);
    }
    
    sub method {
       my ($self) = @_;
    
    # <govnokod location="here">
       $self->_export_data({
          map { __PACKAGE__->$_ => $self->{'_' . lc $_} } qw(PASSWORD PROFILE ROOT_USER_DN)
       });
    # </govnokod>
    }
    
    package main;
    
    # быстро создадим обьект (чтоб не копировать конструктор)
    my $obj = bless {
        _password     => 'foo',
        _profile      => 'bar/baz',
        _root_user_dn => 'cn=root,dc=example,dc=com'
    } => 'Whatever';
    
    $obj->method();

    Захотелось вы**нуться: експортнуть несколько значений внутри обьекта по константам с такими же названиями...

    Elvenfighter, 09 Марта 2016

    Комментарии (25)
  7. Perl / Говнокод #18534

    +771

    1. 1
    2. 2
    3. 3
    4. 4
    5. 5
    6. 6
    7. 7
    8. 8
    use strict;
    use warnings;
     
    my ($i, $j) = (42, 13);
     
    my $max = [ $i => $j ]->[ $i <= $j ];
     
    print "max: $max\n";

    Вот-так вот: http://ideone.com/2Rd3Mr

    // Вроди где-то в PBP этот пример даже есть

    #13520

    Elvenfighter, 26 Июля 2015

    Комментарии (21)
  8. Perl / Говнокод #18067

    +101

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    $utm = `$utmcalc_cmd $user $YEAR $MONTH` || "error";
    if ($oldtarif_mar == 16 || $oldtarif_mar == 17 || $oldtarif_mar == 19 || $oldtarif_mar == 27 || $oldtarif_mar == 45) {
    	if ($newtarif_mar == 16 || $newtarif_mar == 17 || $newtarif_mar == 19 || $newtarif_mar == 27 || $newtarif_mar == 45) {
    		$money2 = (($oldtarif_abonplata/30)*$daystoeom) - (($newtarif_abonplata/30)*$daystoeom);
    #		$nm1 = 0;
    	} else {
    		$money2 = (($oldtarif_abonplata/30)*$daystoeom) - (($newtarif_abonplata/30)*$daystoeom);
    #		$nm1 = $utm;
    	}
    } elsif ($oldtarif_mar != 16 || $oldtarif_mar != 17 || $oldtarif_mar != 19 || $oldtarif_mar != 27 || $oldtarif_mar != 45) {
    	if ($newtarif_mar == 16 || $newtarif_mar == 17 || $newtarif_mar == 19 || $newtarif_mar == 27 || $newtarif_mar == 45) {
    #		$money2 = $oldtarif_abonplata - ($utm*$oldtarif_koef) - (($newtarif_abonplata/30)*$daystoeom);
    		$money2 = (($oldtarif_abonplata/30)*$daystoeom) - (($newtarif_abonplata/30)*$daystoeom);
    #		$nm1 = -$cur_nm;
    	} else {
    #		$money2 = $oldtarif_abonplata - ($utm*$oldtarif_koef) - (($newtarif_abonplata/30)*$daystoeom);
    		$money2 = (($oldtarif_abonplata/30)*$daystoeom) - (($newtarif_abonplata/30)*$daystoeom);
    #		$nm1 = -(($newtarif_lymit/30)*$DAY);
    	}
    }

    Из биллинга одного довольно крупного интернет-провайдера
    Кто-то что-то хотел закомментить...

    begemot, 27 Апреля 2015

    Комментарии (1)
  9. Perl / Говнокод #17485

    −37

    1. 1
    2. 2
    3. 3
    4. 4
    5. 5
    my @arr = (1,2,3,4);
    foreach (@arr) 
    {
       threads->new(\&doSomething, $_)->join;
    }

    Цикл на 4...? Запуск потоков.

    BoBikeR, 20 Января 2015

    Комментарии (4)
  10. Perl / Говнокод #17143

    −19

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    25. 25
    26. 26
    27. 27
    28. 28
    29. 29
    30. 30
    31. 31
    32. 32
    33. 33
    34. 34
    35. 35
    36. 36
    37. 37
    38. 38
    39. 39
    40. 40
    41. 41
    42. 42
    43. 43
    sub rotate {
        my ($filename, $max_entries) = @_;
        $max_entries //= 10; # TODO: make infinity available
    
        return if (! -f $filename);
    
        my ($name, $dir, $suffix) = fileparse($filename, qr/\.[^.]*$/);
    
        my %old_files = ();
        my $shift_max = 0; # maximum number of file that is going to be rotated
        my $glob = File::Spec->catfile($dir, $name . '.*' . $suffix);
        for my $file (glob qq/"$glob"/) {
            my ($number) = $file =~ /\.(\d+)\Q$suffix\E$/;
    
            $old_files{$number} = $file if (defined $number);
            $shift_max++ while (exists $old_files{$shift_max + 1});
        }
    
        $shift_max = $max_entries - 1 if ($shift_max >= $max_entries);
        # how many files to remove from the end
        my $to_remove = scalar(keys %old_files) - $max_entries;
    
        # rename and unlink
        for my $number (sort { $b <=> $a } keys %old_files) {
            my $file = $old_files{$number};
    
            if ($to_remove-- > 0) {
                print "## DEBUG: unlink $file\n";
                unlink($file)
                    or croak('Cannot unlink ' . $file);
            } elsif ($number <= $shift_max) {
                my $new_name = File::Spec->catfile($dir, $name . '.' . ($number + 1) . $suffix);
                print "## DEBUG: rename $file -> $new_name\n";
                rename($file, $new_name)
                    or croak('Cannot rename ' . $file . ' to ' . $new_name);
            }
        }
    
        my $new_name = File::Spec->catfile($dir, $name . '.1' . $suffix);
        print "## DEBUG: rename $filename -> $new_name\n";
        rename($filename, $new_name)
            or croak('Cannot rename ' . $filename . ' to ' . $new_name);
    }

    Продолжаем парад велосипедов. Сделал ротацию бекап-архивов :-{

    Elvenfighter, 20 Ноября 2014

    Комментарии (10)