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

    −126

    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
    58. 58
    59. 59
    60. 60
    61. 61
    62. 62
    63. 63
    64. 64
    65. 65
    66. 66
    67. 67
    68. 68
    69. 69
    70. 70
    71. 71
    72. 72
    73. 73
    74. 74
    sub Tgetent {
        local($TERM) = @_;
        local($TERMCAP,$_,$entry,$loop,$field);
    
        # warn "Tgetent: no ospeed set" unless $ospeed;
        foreach $key (keys %TC) {
    	delete $TC{$key};
        }
        $TERM = $ENV{'TERM'} unless $TERM;
        $TERM =~ s/(\W)/\\$1/g;
        $TERMCAP = $ENV{'TERMCAP'};
        $TERMCAP = '/etc/termcap' unless $TERMCAP;
        if ($TERMCAP !~ m:^/:) {
    	if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) {
    	    $TERMCAP = '/etc/termcap';
    	}
        }
        if ($TERMCAP =~ m:^/:) {
    	$entry = '';
    	do {
    	    $loop = "
    	    open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
    	    while (<TERMCAP>) {
    		next if /^#/;
    		next if /^\t/;
    		if (/(^|\\|)${TERM}[:\\|]/) {
    		    chop;
    		    while (chop eq '\\\\') {
    			\$_ .= <TERMCAP>;
    			chop;
    		    }
    		    \$_ .= ':';
    		    last;
    		}
    	    }
    	    close TERMCAP;
    	    \$entry .= \$_;
    	    ";
    	    eval $loop;
    	} while s/:tc=([^:]+):/:/ && ($TERM = $1);
    	$TERMCAP = $entry;
        }
    
        foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
    	if ($field =~ /^\w\w$/) {
    	    $TC{$field} = 1;
    	}
    	elsif ($field =~ /^(\w\w)#(.*)/) {
    	    $TC{$1} = $2 if $TC{$1} eq '';
    	}
    	elsif ($field =~ /^(\w\w)=(.*)/) {
    	    $entry = $1;
    	    $_ = $2;
    	    s/\\E/\033/g;
    	    s/\\(200)/pack('c',0)/eg;			# NUL character
    	    s/\\(0\d\d)/pack('c',oct($1))/eg;	# octal
    	    s/\\(0x[0-9A-Fa-f][0-9A-Fa-f])/pack('c',hex($1))/eg;	# hex
    	    s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
    	    s/\\n/\n/g;
    	    s/\\r/\r/g;
    	    s/\\t/\t/g;
    	    s/\\b/\b/g;
    	    s/\\f/\f/g;
    	    s/\\\^/\377/g;
    	    s/\^\?/\177/g;
    	    s/\^(.)/pack('c',ord($1) & 31)/eg;
    	    s/\\(.)/$1/g;
    	    s/\377/^/g;
    	    $TC{$entry} = $_ if $TC{$entry} eq '';
    	}
        }
        $TC{'pc'} = "\0" if $TC{'pc'} eq '';
        $TC{'bc'} = "\b" if $TC{'bc'} eq '';
    }

    Гениальный код.

    Arigato, 01 Ноября 2010

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

    −125

    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
    while (<>)
      {
        chomp;
        s/\r$//;
        next unless $_;
        my ($tag, $value) = split / /, $_, 2;
        die "Font is not fixed width\n"
          if $tag eq 'SPACING' and not $value =~ /[CM]/i;
    
        $currentchar = $value if $tag eq 'ENCODING';
        $minchar = $currentchar if not defined $minchar
          or ($currentchar < $minchar && $currentchar >= 0);
        $maxchar = $currentchar if not defined $maxchar
          or ($currentchar > $maxchar && $currentchar >= 0);

    И дальше в том же духе...
    Взято из файла bdf2gdfont.pl

    Arigato, 01 Ноября 2010

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

    −124

    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
    # Relocate
    if (open(my $reloc, "support/reloc.txt")) {
        # ...
        print "Relocating...";
        my $count = 0;
        local $_;
        while (<$reloc>) {
    	chomp;
    	my($type, $f) = split(' ', $_, 2);
    	$f = "$prefix/$f";
    	$f =~ s,/,\\,g;
    	#print "Relocating $f...\n";
    	my $read_only;
    	unless (-w $f) {
    	    $read_only++;
    	    run("\@attrib", "-r", $f);
    	}
    
    	open(my $fh, "+<", $f) || die "Can't open $f: $!";
    	binmode($fh);
    	my $content = do { local $/; <$fh> };
    
    	if ($type eq "B") {
    	    $content =~ s,\Q$sponge\E([^\0]*),$prefix$1$binary_pad,go;
    	}
    	else {
    	    $content =~ s,\Q$sponge\E,$prefix,go;
    	    $content =~ s,\Q$sponge_str\E,$prefix_str,go if $^O eq "MSWin32";
    	    truncate($fh, length($content)) || die "Can't truncate '$f': $!";
    	}
    
    	seek($fh, 0, 0) || die "Can't reset file pos on '$f': $!";
    	print $fh $content;
    	close($fh) || die "Can't write back content to '$f': $!";
    
    	run("\@attrib", "+r", $f) if $read_only;
    
    	$count++;
        }
        print "done ($count files relocated)\n";
    }

    установщик перл...
    reloc.txt содержит 137 файлов.

    seonull, 01 Ноября 2010

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

    −118

    1. 1
    return (($publish && $filename ne '--') ? 1 : 0);

    Особенно умиляют скобочки

    krushi, 29 Октября 2010

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

    −122

    1. 1
    my $exp_data = $map->get_experiments_data($gg, $map, $signals_sign, $distinct_lists);

    Пуленепробиваемый код! На случае, если вдруг объект забудет, кто он такой.

    krushi, 29 Октября 2010

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

    −120

    1. 1
    print qq(<div id="Layer26" class="blank" style="left:170mm; top:96mm; width:95mm;">$base1[17]);

    Верстаем в миллиметрах, используем магические числа и т.п.

    hdkeeper, 22 Октября 2010

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

    −156

    1. 1
    2. 2
    3. 3
    if (ref($val) eq 'ARRAY') {
       # ...
    }

    seonull, 13 Октября 2010

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

    −117

    1. 1
    2. 2
    3. 3
    4. 4
    5. 5
    6. 6
    7. 7
    $sth=$dbh->prepare("SELECT count(*) FROM ".SQL_ADMIN_TABLE." WHERE type='ipban' AND ? & ival2 = ival1 & ival2;") or make_error(S_SQLFAIL);
     $sth->execute($numip) or make_error(S_SQLFAIL);
       if(($sth->fetchrow_array())[0])
       {
    	  $sth=$dbh->prepare("SELECT comment FROM ".SQL_ADMIN_TABLE." WHERE type='ipban'   AND ? & ival2 = ival1 & ival2;") or make_error(S_SQLFAIL);
    	  $sth->execute($numip) or make_error(S_SQLFAIL);
      }

    хуита, 07 Октября 2010

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

    −247

    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
    if($ENV{'mode'} eq "dialup"){
      if($ENV{'login'}=~/^P/){
        if($ENV{'bill'}){
          if($ENV{'passwd1'}){
            if($ENV{'passwd1'} eq $ENV{'passwd2'}){
    	  if($ENV{'email'}){
                my($rUser)=check_radius_user_new($ENV{'login'});
    	    my($sUser)=check_http_user_new($ENV{'login'});
    	   #my($Email)=Check_MailBox($ENV{'login'},$ENV{'email'});
        	    if(($rUser==0)and($sUser==0)and($Email==0)){
                  my($bUser)=check_billing_user($ENV{'bill'});
    	      if($bUser==0){
                    add_radius_user($ENV{'login'},$ENV{'passwd1'});
    	        add_http_user($ENV{'login'},$ENV{'passwd1'});
        	        add_billing($ENV{'login'},$ENV{'bill'});
    		Add_MailBox($ENV{'login'},$ENV{'email'},$ENV{'passwd1'});
            	$ENV{'message'}="User created";
                  }else{$ENV{'message'}="Error: Billing name is already exist";}
    	      if($Email!=0){$ENV{'message'}="Error: Email name or alias is already exist";}
                }else{$ENV{'message'}="Error: Sorry such login is already exist";}
    	  }else{$ENV{'message'}="Error: Enter e-mail";}
            }else{$ENV{'message'}="Error: Password mistake";}
          }else{$ENV{'message'}="Error: Enter password";}
        }else{$ENV{'message'}="Error: Enter billing name";}		
      }else{$ENV{'message'}="Error: Enter login";}
    }else{$ENV{'message'}="Error: ";}
    $ENV{'message'}=~s/ /\%20/g;

    Может это так и надо делать?

    Werdn, 30 Августа 2010

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

    −117

    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
    my $arr=[];
    my $res=$dbr->selectrow_arrayref("SELECT DISTINCT obj.value
    FROM obj
    INNER JOIN ...
    INNER JOIN ...
    INNER JOIN ...
    INNER JOIN ...
    INNER JOIN ...
    WHERE ..... 
    сложный, но не интересный SQL-запрос к наскольким таблицам под лям записей в каждом
    ...");
    arm_ls.lsid IN ($ls_str)
    
    foreach $row (@$res)
    {
    push(@$arr,$row->[0]) if (!grep(/^$row->[0]$/,@$arr));
    }
    my $sum=@$arr;
    return $sum;

    Нашел тут в одном проекте. Теперь хочу поделиться с вами великолепным способом получения числа уникальных значений из таблицы.
    В этот способ научит вас использовать всю мощь перла.

    Mihard, 26 Августа 2010

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