Pascal — Говнокод.ру

Pascal / Говнокод #23147

0

01
02
03
04
05
06
07
08
09
10

TServerThread = class(TThread)
  private
    procedure DoReadData;
  protected
    ThreadOwner: TIPCServer;
    procedure Execute; override;
    constructor Create(AThreadOwner: TIPCServer);
    destructor Destroy; override;
  public
  end;

Мы кодили, кодили и наконец накодили!

antipattern, 27 Июня 2017

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

Pascal / Говнокод #23137

0

01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95

procedure TForm1.ProcListAdvancedCustomDrawItem(Sender: TCustomListView;
  Item: TListItem; State: TCustomDrawState; Stage: TCustomDrawStage;
  var DefaultDraw: Boolean);
var
  TP:TprocessInfo;
  xColor: TColor;
  xRect: TRect;
  xBitmap: TBitmap;
  I, L, R: Integer;
begin
  DefaultDraw:=False;
  TP:=TProcessInfo(Item.SubItems.Objects[0]);
  if (Item.Selected) then
  begin
    if Sender.Focused then
    begin
      if (FItemAtCursor <> -1) and (Item.Index = FItemAtCursor) then
        xColor:=clNavy
      else
        xColor:=$00C56A31;
    end
    else
      xColor:=$00D8E9EC
  end
  else
  begin
    if (TP.New<2) or (TP.Terminated<2) or (TP.Hidden) then
    begin

      if ShowDangerousProcesses then
      if TP.Hidden then
      xColor:=$00DBDBDB;

      if ShowNewProcesses then
      if TP.New <2 then
      xColor:=$001DEB2D;

      if ShowTerminatedProcesses then
      if TP.Terminated < 2 then
      xColor:=$001D2DEB;
    end
    else

    if (Item.Index mod 2 = 1) then
    xColor:=RGB(245,245,255)
    else
    xColor:=clWindow;
  end;
  Sender.Canvas.Brush.Color:=xColor;
  DefaultDraw:=True;

  if (Item.Selected) and Sender.Focused
  then Sender.Canvas.Font.Color:=clWindow
  else Sender.Canvas.Font.Color:=clWindowText;
  Sender.Canvas.FillRect(Item.DisplayRect(drLabel));
  DefaultDraw:=True;

  Exit; 

  xRect:=Item.DisplayRect(drLabel);
  Sender.Canvas.TextRect(xRect,xRect.Left+2,xRect.Top,Item.Caption);

  for I:=0 to TListView(Sender).Columns.Count-1 do
  begin
    if TListView(Sender).Columns[TListView(Sender).Columns[I].ID].Width<=0 then Continue;
    if (I=0) and (TListView(Sender).Columns[I].ID <> 0) then
    begin
      xRect.Left:=0;
      xRect.Right:=xRect.Left+TListView(Sender).Columns.Items[TListView(Sender).Columns[I].ID].Width-1;
      Sender.Canvas.FillRect(xRect);
      Sender.Canvas.TextRect(xRect,xRect.Left+2,xRect.Top,Item.SubItems[TListView(Sender).Columns[I].ID-1]);
    end
    else
    begin
    if I>0 then
    begin
      xRect.Left:=xRect.Right+1;
      xRect.Right:=xRect.Left+TListView(Sender).Columns.Items[TListView(Sender).Columns[I].ID].Width-1;
      Sender.Canvas.FillRect(xRect);
      if TListView(Sender).Columns[I].ID >0 then
      Sender.Canvas.TextRect(xRect,xRect.Left+5,xRect.Top,Item.SubItems[Pred(TListView(Sender).Columns[I].ID)])
      else
      begin
        L:=(Item.DisplayRect(drIcon).Right-Item.DisplayRect(drIcon).Left)+6;
      Sender.Canvas.TextRect(xRect,xRect.Left+L,xRect.Top, Item.Caption)
    end;
    end;

    end;
  end;
  Sender.Canvas.Brush.Color:=clWindow;
  Sender.Canvas.FillRect(Item.DisplayRect(drIcon));
  if Item.ImageIndex=-1 then Exit;
  xBitmap:=TBitmap.Create;
  TListView(Sender).SmallImages.GetBitmap(Item.ImageIndex,xBitmap);

ListView - великий и ужасный! - в режиме OwnerDraw.
Писал диспетчер процессов. Когда я разрешил прятать столбцы и включил свойство FullDrag, моя жизнь круто изменилась.

antipattern, 19 Июня 2017

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

Pascal / Говнокод #23106

−1

1
2

(багрепорт)
http://www.alphaskins.com/forum/index.php?app=core&module=attach&section=attach&attach_rel_module=post&attach_id=8330Сергох Гончаров с AlphaSkins.com шалит )

Сергох Гончаров с AlphaSkins.com шалит )

antipattern, 06 Июня 2017

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

Pascal / Говнокод #23100

0

01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44

function IsExecutablePacked(FileName: WideString): Boolean;
var
i: Cardinal;
CompressionRatio: Double;
Count: Cardinal;
MathX: array [0 .. 255] of Integer;
FileStream: TFileStream;
Buffer: PAnsiChar;
FileHandle: THandle;
begin
Result := False;
try
FileHandle := 0;
FileHandle := CreateFileW(PWideChar(FileName), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_DELETE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if (FileHandle <> 0) and FileExists(FileName) then
begin
try
FileStream := TFileStream.Create(FileHandle);
Count := FileStream.Seek(0, soFromEnd);
try
GetMem(Buffer, Count);
FileStream.Seek(0, soFromBeginning);
FileStream.Read(Buffer^, Count);
CompressionRatio := 0;
FillChar(MathX, Sizeof(MathX), 0);
for i := 0 to Count - 1 do
Inc(MathX[Windows.PByte(DWORD(Buffer) + (i))^]);
for i := 0 to 255 do
if MathX > 0 then
CompressionRatio := CompressionRatio - Log2(MathX / Count) * MathX;
finally
FreeMem(Buffer, Count);
end;
CompressionRatio := (Count * 8) / CompressionRatio;
CompressionRatio := 100 / CompressionRatio;
if CompressionRatio > 97 then
Result := True;
finally
FileStream.Free;
end;
end;
finally
end;
end;

"Ис Эксекутабле Пуцкед" - форматирование сохранено.

antipattern, 04 Июня 2017

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

Pascal / Говнокод #22991

−1413

01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39

function Unescape(const s: AnsiString): widestring;
var
  i: Integer;
  j: Integer;
  c: Integer;
begin
  // Make result at least large enough. This prevents too many reallocs
  SetLength(Result, Length(s));
  i := 1;
  j := 1;
  while i <= Length(s) do begin
    if s[i] = '\' then begin
      if i < Length(s) then begin
        // escaped backslash?
        if s[i + 1] = '\' then begin
          Result[j] := '\';
          inc(i, 2);
        end
        // convert hex number to WideChar
        else if (s[i + 1] = 'u') and (i + 1 + 4 <= Length(s))
                and TryStrToInt('$' + string(Copy(s, i + 2, 4)), c) then begin
          inc(i, 6);
          Result[j] := WideChar(c);
        end else begin
          raise Exception.CreateFmt('Invalid code at position %d', [i]);
        end;
      end else begin
        raise Exception.Create('Unexpected end of string');
      end;
    end else begin
      Result[j] := WideChar(s[i]);
      inc(i);
    end;
    inc(j);
  end;

  // Trim result in case we reserved too much space
  SetLength(Result, j - 1);
end;

Это не вирус. Просто в Delphi 7 не завезли JSon.

doctor_stertor, 07 Мая 2017

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

Pascal / Говнокод #21288

−77

1
2
3
4
5
6
7
8

program LeakMem;

uses sysutils;

var
   str:string;

...

В седьмой делфе утекает память.

voodoodal16, 28 Сентября 2016

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

Pascal / Говнокод #21129

+8

01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39

Program L_121;
uses crt;
Var N : integer;
b,z : string;
f1 : text;

Begin
     assign(f1,'Единица измерения.txt');
     writeln('1 Соотношение конкретной единицы измерения длины');
     writeln('2 Соотношение единиц измерения длины');
     writeln('3 Обозначение единиц измерения длины');
     writeln('4 Назначение единиц измерения длины');
     read(N);clrscr;
     reset(f1);
     case N of
     
     1:begin
            write('Введите единицу измерения : ');
            read(b);clrscr;
            readln(f1,z);writeln(z);
            if b='миллиметр' then begin readln(f1,z);writeln(z); end;
            if b='сантиметр' then begin readln(f1,z);readln(f1,z);writeln(z); end;
            if b='дециметр'  then begin readln(f1,z);readln(f1,z);readln(f1,z);writeln(z);end;
            if b='метр'      then begin readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);writeln(z);end;
            if b='километр'  then begin readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);writeln(z); end;
       end;
     2:begin
            readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);
       end;
     3:begin
            readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);
            writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);
       end;
     4:begin
            readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);readln(f1,z);
            readln(f1,z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);readln(f1,z);writeln(z);
       end;
     end;
End.

4 года назад я так писал код)

Genome, 07 Сентября 2016

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

Pascal / Говнокод #20875

+1870

01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

function translate_a_name_of_the_winter_to_the_foreign_language(language: String): String;
  begin
    if      language = 'авестийский'    Result := 'zimō'
    else if language = 'белорусский'    Result := 'зіма'
    else if language = 'болгарский'     Result := 'зима'
    else if language = 'верхнелужицкий' Result := 'zyma'
    else if language = 'греческий'      Result := 'χειμώνας'
    else if language = 'древнепрусский' Result := 'semo'
    else if language = 'латинский'      Result := 'hiems'
    else if language = 'латышский'      Result := 'ziema'
    else if language = 'литовский'      Result := 'žiema'
    else if language = 'македонский'    Result := 'зима'
    else if language = 'нижнелужицкий'  Result := 'zyma'
    else if language = 'осетинский'     Result := 'зымӕг'
    else if language = 'польский'       Result := 'zima'
    else if language = 'русский'        Result := 'зима'
    else if language = 'санскрит'       Result := 'hima'
    else if language = 'сербский'       Result := 'зима'
    else if language = 'словацкий'      Result := 'zima'
    else if language = 'словенский'     Result := 'zima'
    else if language = 'талышский'      Result := 'зымыстон'
    else if language = 'таджикский'     Result := 'зимистон'
    else if language = 'украинский'     Result := 'зима'
    else if language = 'хорватский'     Result := 'zima'
    else if language = 'чешский'        Result := 'zima'
  end;

Из одного очень серьёзного проекта.

Amayak_Akopyan, 20 Августа 2016

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

Pascal / Говнокод #18814

+2

1
2
3
4
5
6
7
8
9

case ((((parametr[3, 1] - parametr[1, 1]) / parametr[4, 2] = (parametr[3, 2] - parametr[1, 2]) / parametr[4, 2]) and ((parametr[3, 2] - parametr[1, 2]) / parametr[4, 2] = (parametr[3, 3] - parametr[1, 3]) / parametr[4, 3])) xor           
            ((parametr[4, 1] = 0) and (parametr[1, 1] = parametr[2, 1]) and (parametr[2, 1] = parametr[3, 1]) and ((parametr[3, 2] - parametr[1, 2]) / parametr[4, 2] = (parametr[3, 3] - parametr[1, 3]) / parametr[4, 3])) xor          
             ((parametr[4, 2] = 0) and (parametr[1, 2] = parametr[2, 2]) and (parametr[2, 2] = parametr[3, 2]) and ((parametr[3, 1] - parametr[1, 1]) / parametr[4, 1] = (parametr[3, 3] - parametr[1, 3]) / parametr[4, 3])) xor                           
                ((parametr[4, 3] = 0) and (parametr[1, 3] = parametr[2, 3]) and (parametr[2, 3] = parametr[3, 3]) and ((parametr[3, 1] - parametr[1, 1]) / parametr[4, 1] = (parametr[3, 2] - parametr[1, 2]) / parametr[4, 2])) xor             
                   ((parametr[4, 3] <> 0) and (parametr[4, 1] = 0) and (parametr[4, 2] = 0) and (parametr[3, 1] = parametr[2, 1]) and (parametr[3, 2] = parametr[2, 2])) xor                    
                      ((parametr[4, 2] <> 0) and (parametr[4, 1] = 0) and (parametr[4, 3] = 0) and (parametr[3, 1] = parametr[2, 1]) and (parametr[3, 3] = parametr[2, 3])) xor                       
                         ((parametr[4, 1] <> 0) and (parametr[4, 2] = 0) and (parametr[4, 3] = 0) and (parametr[3, 2] = parametr[2, 2]) and (parametr[3, 3] = parametr[2, 3])) xor                         
                            ((parametr[4, 1] = 0) and (parametr[4, 2] = 0) and (parametr[4, 3] = 0))) of true:
         writeln('Все точки лежат на одной прямой. Такой треугольник не существует.');

Проверка треугольника в декартовой системе координат

Meliodas, 04 Октября 2015

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

Pascal / Говнокод #18756

+5

1

Commission:= Commission/100*StrToInt(Label8.Caption); //Вычисление комиссии

Терминальщики :|

Dego1n, 23 Сентября 2015

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

Говнокод: по колено в коде.