Главная страница
Top.Mail.Ru    Яндекс.Метрика
Текущий архив: 2005.12.25;
Скачать: CL | DM;

Вниз

Примеры кода, достойные орехов.   Найти похожие ветки 

 
Владислав ©   (2005-11-29 15:17) [0]

Нашел вот такой код в большом проекте.
Сохранено авторское форматирование кода. Комментарии мои.

//**********************************************************************************

// Процедура увеличивает длину строки S до Len и добавляет в конец строки S пробелы.

 procedure UpdateLength(var S: string; Len: integer);
 var
   I: integer;
 begin
   for I := Length(S) + 1 to Len do
     S := S + " ";
 end;

// Пример использования.
// Выравниваем длину строк S1, S2 и S3, добавляя в конец строк пробелы.

 if S1 > S2
   then MaxLen := Max(Length(S1), Length(S3))
   else MaxLen := Max(Length(S2), Length(S3));
 UpdateLength(S1, MaxLen);
 UpdateLength(S2, MaxLen);
 UpdateLength(S3, MaxLen);

//**********************************************************************************

// Ожидаем, пока пользователь не нажмет кнопку на немодальной форме

 while FProgress.ModalResult = mrNone do
   Application.ProcessMessages;

//**********************************************************************************

// Этот тип нам понадобится, чтобы добраться до protected свойства

type
 TThreadAccess = class(TBaseAsyncRunThread);

// Следующий код выполняет главный поток приложения.
// Здесь проверяется (я бы сказал, кто-то хотел, чтобы проверялось) завершился ли дополнительный поток.
// Свойство Terminated определено в TThread. Правда почему то protected.
// Для проверки этого свойства и понадобился класс TThreadAccess.
// Если Terminated = True, уничтожаем экземпляр класса, наследника TThread.
// Если же Terminated = False, убиваем поток на сервере баз данных.
// Процедуру Terminate при этом никто и не подумал вызвать.
// Справедливости ради, надо заметить, что этот код работал.
// Ни разу не было никаких исключений типа Access Violation,
// а то, что при этом убивался серверный процесс - особенности реализации...

     if TThreadAccess(FThreadList[I]).Terminated then
       TBaseAsyncRunThread(FThreadList[I]).Free
     else begin
       TBaseAsyncRunThread(FThreadList[I]).ClearNotify;
       KillServerProcess(TBaseAsyncRunThread(FThreadList[I]));

//**********************************************************************************

// Ничего необычного. Объявлен тип метода.

 TMonitorEventProc = procedure(Connection: TADOConnection; const Sql, ErrMsg: string;
   IsStart: Boolean; RecsAff: Integer) of object;

// Тоже ничего необычного. Глобальная переменная типа метод объекта.

 MonitorProc: TMonitorEventProc = nil;

// Проверяем, присвоен ли наш обработчик неких событий глобальной переменной.
// Если установлен, ничего не делаем, но событий ждем.
// А то, что у методов есть еще какая-то там TMethod.Data -
// пусть волнует тех, кто об этом знает.

 if @MonitorProc <> @TfmMonitor.MonitorEvent then
 begin
   MonitorProc := MonitorEvent;
 end;

//**********************************************************************************


У кого есть что-то подобное, чтобы поделиться?..

P.S.: Почему-то этот код вместо улыбки вызывает разочарование и уныние :(


 
Ega23 ©   (2005-11-29 15:21) [1]


function TfmMain.IncDay(const DateTime: TDateTime;  NumberOfDays: Integer): TDateTime;
{Функция предназначена для изменения даты (DateTime) путем добавления  количества дней (NumberOfDays). Значение NumberOfDays может быть отрицательным.}
var
 Y, M, D, CountDays: Word;
 N: Integer;
 Sign, NoBreak: Boolean;
begin
 Sign := NumberOfDays >= 0;
 DecodeDate(DateTime, Y, M, D);
 N := NumberOfDays;
 NoBreak := True;
 if Sign then   //Прибавить
 begin
   while(NoBreak) do
   begin //Количество дней в месяце
     CountDays := MonthDays[IsLeapYear(Y), M];
     if (N + D) <= CountDays then //Если в пределах данного месяца
     begin
       Inc(D, N);
       NoBreak := False;
     end
     else
     begin
       if M < 12 then
         Inc(M, 1)
       else
       begin
         M := 1;
         Inc(Y, 1);
       end;
       N := N - (CountDays - D);
       D := 0;
     end;
   end;
 end
 else  //Отнять
 begin
   N := -N;
   while(NoBreak) do
   begin
     if D > N then  //Если в пределах данного месяца
     begin
       Dec(D, N);
       NoBreak := False;
     end
     else
     begin
       if M > 1 then
         Dec(M, 1)
       else
       begin
         M := 12;
         Dec(Y, 1);
       end;
       //Количество дней в месяце
       CountDays := MonthDays[IsLeapYear(Y), M];
       N := N - D;
       D := CountDays;
     end;
   end;  
 end;
 Result := EncodeDate(Y, M, D);
 //Установить время из старой даты
 ReplaceTime(Result, DateTime);
end;


 
Джо ©   (2005-11-29 15:22) [2]


>  [1] Ega23 ©   (29.11.05 15:21)

8-()
Надеюсь, автора уже убили садистским способом или он все еще гуляет на свободе среди нас?!
:)


 
Ega23 ©   (2005-11-29 15:24) [3]


> Надеюсь, автора уже убили садистским способом или он все
> еще гуляет на свободе среди нас?!


IncDay - это классика! Собственно говоря, я из-за неё на delphimaster ходить начал. Кто-то из приятелей ссылку прислал, чтобы поржать.
Текст уже года 3 висит на стенке.  :о)


 
Nikolay M. ©   (2005-11-29 15:25) [4]


> Ega23 ©   (29.11.05 15:21) [1]
> Владислав ©   (29.11.05 15:17)  

Это все детский лепет.
Учу писать программы, дорого:
http://www.rsdn.ru/Forum/Message.aspx?mid=1320137&only=1


 
Igorek ©   (2005-11-29 15:27) [5]

Ну про банер мелкософта я уже писал..


 
Суслик ©   (2005-11-29 15:31) [6]

у меня полно такого, в основном собственной разработки.
работает 10й год, ну и слава богу :)

иногда бывают потуги отрефаторить чего-то.

но довести до конца времени нет, и, прямо скажем, резковыраженной необходимости.


 
Lamer@fools.ua ©   (2005-11-29 15:31) [7]

Шо-то у всех так длинно. Я попроще встречал (VB.NET):

Public Function DoSomething() As Boolean
   Dim retValue As Boolean

   " Ту шо-то считаем

   If retValue = True Then
       Return True
   Else
       Return False
   End if
End Function


 
Ega23 ©   (2005-11-29 15:34) [8]

If retValue = True Then
      Return True
  Else
    if retValue = False then
      Return False
  End if


:о)


 
Джо ©   (2005-11-29 15:34) [9]


>  [4] Nikolay M. ©   (29.11.05 15:25)

:))))
Под столом.


 
alex_*** ©   (2005-11-29 15:35) [10]

[7] это классика :) . Даже на собеседовании как-то попросили упростить что-то типа этого


 
Nikolay M. ©   (2005-11-29 15:39) [11]


> Джо ©   (29.11.05 15:34) [9]

Был там же по прочтении. Каменты рулят :)


 
Владислав ©   (2005-11-29 15:45) [12]

Таки вызвало улыбку :)
Нет худа без добра :)


 
Digitman ©   (2005-11-29 15:50) [13]

Вот такой код я имел "удовольствие" узреть в проекте одного "реального пацана", всеръез водившего (и по сей день водящего) за нос одного из солидных заказчиков в Московии:

if (tp=TClass($7C509300)) or (tp=TClass($7D73E190))  or (tp=TClass($7D73C270)) or (tp=TClass($775E98D8))
then ...

это даже не столько орех, сколько диверсия)


 
Джо ©   (2005-11-29 15:55) [14]


>
>  [13] Digitman ©   (29.11.05 15:50)

Жестоко.


 
Владислав ©   (2005-11-29 15:56) [15]


> это даже не столько орех, сколько диверсия)


Это уж точно диверсия!


 
pasha_golub ©   (2005-11-29 15:56) [16]


> Digitman ©   (29.11.05 15:50) [13]


А шо оно делать должно? Не понимаю я, к сожалению


 
Джо ©   (2005-11-29 15:57) [17]


> [13] Digitman ©   (29.11.05 15:50)

Он, надо полагать, ссылки менял после каждой модификации программы? Садомазо...


 
Ega23 ©   (2005-11-29 15:57) [18]


> if (tp=TClass($7C509300)) or (tp=TClass($7D73E190))  or
> (tp=TClass($7D73C270)) or (tp=TClass($775E98D8))
> then ...
>


А как оно работает????


 
Digitman ©   (2005-11-29 16:01) [19]

логика автора сего шедевра на редкость проста и убивает наповал (услышано прямо из его уст) - мол, у меня это работает, у заказчика - тоже, пока я якшаюсь с заказчиком - это мои проблемы, а после меня хоть потоп)


 
Суслик ©   (2005-11-29 16:01) [20]

Они еще спрашивают!
А сами орехи суют :)


 
Digitman ©   (2005-11-29 16:04) [21]


> Джо ©   (29.11.05 15:57) [17]


в том-то и дело, что не менял) ... до поры до времени ему просто везло и везет)


 
Digitman ©   (2005-11-29 16:07) [22]


> pasha_golub ©   (29.11.05 15:56) [16]


таким образом автор сего чуда программерской мысли пытается идентифицировать класс некоего своего объекта, сравнивая со ссылками на записи о классах в RTTI


 
Ega23 ©   (2005-11-29 16:07) [23]


> Они еще спрашивают!
> А сами орехи суют :)


В смысле, а где гарантия, что указатель только по этим четырём адресам будет?
Или всё-таки, шансы высоки?


 
Суслик ©   (2005-11-29 16:09) [24]

это может быть одно из средств защиты своего приложения :)
грубое, но все же.


 
Суслик ©   (2005-11-29 16:10) [25]


> В смысле, а где гарантия, что указатель только по этим четырём
> адресам будет?
> Или всё-таки, шансы высоки?

насколько я понимаю они грузятся в rtl.
Наверно (не проверял) можно заставить грузиться ее по одному адресу.


 
Суслик ©   (2005-11-29 16:10) [26]


> В смысле, а где гарантия, что указатель только по этим четырём
> адресам будет?
> Или всё-таки, шансы высоки?

насколько я понимаю они грузятся в rtl.
Наверно (не проверял) можно заставить грузиться ее по одному адресу.


 
msguns ©   (2005-11-29 16:11) [27]

>Ega23 ©   (29.11.05 15:57) [18]
>А как оно работает????

А никак. В смысле then никогда не наступает ;)


 
pasha_golub ©   (2005-11-29 16:11) [28]


> Суслик ©   (29.11.05 16:09) [24]
>
> это может быть одно из средств защиты своего приложения
> :)
> грубое, но все же.
>

Я тоже об этом подумал, но это пипец конечно :0)


 
Суслик ©   (2005-11-29 16:14) [29]

Пипец, конечно. Зато поддерживать твоею же программу будут звать всегда тебя.


 
Digitman ©   (2005-11-29 16:17) [30]


> msguns ©   (29.11.05 16:11) [27]


ну почему же ?

наступает) ... до той поры пока rtl от сеанса к сеансу грузится по одному и тому же (ожидаемому автором шедевра) адресу ... или до той поры пока версия rtl та же что и у автора ... тут удивительно другое - как у заказчика до сих пор это ружьё не выстрелило)


 
jack128 ©   (2005-11-29 16:21) [31]

Nikolay M. ©   (29.11.05 15:25) [4]
я даже могу сказать откуда этот код взялся у Валика. Ему он достался от дяди Борланда. см SysUtils.pas

По теме вот такой код видел:

raise TSomeException.Create(XXX);
DoSomething;


 
Суслик ©   (2005-11-29 16:22) [32]

Сергей, это адназначат защита :)


 
Digitman ©   (2005-11-29 16:27) [33]

вот еще один образчик на ту же тему из того же юнита того же шедевротворца :
(то что фигурирует под Digitman, было ненавязчиво предложено автору мной как солюшн, избавляющий от геморроя, с чем он подозрительно быстро согласился, сославшись на "не было времени переделать этот код как положено")


{$IFDEF Digitman}
function IsInterface(obj: Pointer; const aGUID: TGUID): Boolean;
var
 Intf: IInterface;
begin
 Result := False;
 if Assigned(obj) then
   try
     Result := IUnknown(obj).QueryInterface(aGUID, Intf) = 0;
   except
   end;
end;
{$ENDIF}

..

if
{$IFDEF Digitman}
 IsInterface(Pointer(obj), IXMLNode)
{$ELSE}
 (tp=TClass($561A66)) or (tp=TClass($4fcd6a)) or (tp=TClass($4fcd76)) or (tp=TClass($50540A))
 or (tp=TClass($503ee2)) or (tp=TClass($503f5e)) or (tp=TClass($5B081A)) or (tp=TClass($504ACE))
 or (tp=TClass($503F82)) or (tp=TClass($503F72)) or (tp=TClass($504AB6)) or (tp=TClass($504B3E))
{$ENDIF}
then begin
 tnode:=ixmlnode(pointer(obj));
 with tnode.childnodes do for i1:=0 to count-1 do
   process(pointer(nodes[i1]),adv1,adv2);
end else

if
{$IFDEF Digitman}
 IsInterface(Pointer(obj), ihtmlelement)
{$ELSE}
 (tp=TClass($7C509300)) or (tp=TClass($7D73E190)) or (tp=TClass($7D73C270))
   or (tp=TClass($775e98d8))
{$ENDIF}
then begin
 hnode:=ihtmlelement(pointer(obj));

....


а защитой тут и не пахнет) ... тут дурью отдает изрядно)


 
Владислав ©   (2005-11-29 16:27) [34]


> raise TSomeException.Create(XXX);
> DoSomething;


Своего рода, как бы так выразиться, far exit? :)
Выход из нескольких процедур? :)


 
Ega23 ©   (2005-11-29 16:31) [35]


> Наверно (не проверял) можно заставить грузиться ее по одному
> адресу.


Вот если можно заставить грузиться по одному адресу, то действительно как средство защиты можно рассматривать. Тогда всё понятно.
Только я первый раз про такое слышу.
Собственно, поэтому и спросил...


 
Суслик ©   (2005-11-29 16:35) [36]

Да это я предположил только :)


 
Alkid ©   (2005-11-29 16:36) [37]


> Вот если можно заставить грузиться по одному адресу, то
> действительно как средство защиты можно рассматривать. Тогда
> всё понятно.
> Только я первый раз про такое слышу.
> Собственно, поэтому и спросил...

В принципе каждый модуль (в том числе и .exe) имеет заданный в PE файле базовый адрес. И при расположении сегментов модуля этот базовый адрес используется как точка отсчёта. Можно ли этот факт использовать для защиты - ХЗ.


 
Владислав ©   (2005-11-29 16:42) [38]

Вот же блин!

// Возвращает строку из символов Char длиной Count.
// Одно название модуля говорит за себя!
// Модуль назвается SoStrUtils.

function Chars(C: Char; Count: Integer): string;
var Index: LongInt;
begin
 Result := EmptyStr;
 for Index := 1 to Count do Result := Result + C;
end;


 
Суслик ©   (2005-11-29 16:43) [39]


> function IsInterface(obj: Pointer; const aGUID: TGUID):
> Boolean;
> var
>  Intf: IInterface;
> begin
>  Result := False;
>  if Assigned(obj) then
>    try
>      Result := IUnknown(obj).QueryInterface(aGUID, Intf)
> = 0;
>    except
>    end;
> end;


имхо тоже так себе метод - невесть какая порча памяти теоретически может быть при вызове метода у неизвестно чего.


 
jack128 ©   (2005-11-29 16:47) [40]

Суслик ©   (29.11.05 16:43) [39]
Ну в общем то да. И такое было  
var
 p: pointer;
begin
 ...
 try
   f := TObject(P) is TSomeObject;
 except
   f := False;
 end;
 if f then
   ...
end;

Хотя вероятность некоректных действий тут практически нулевая, но тем не менее..



Страницы: 1 2 3 вся ветка

Текущий архив: 2005.12.25;
Скачать: CL | DM;

Наверх




Память: 0.58 MB
Время: 0.047 c
14-1133531149
Александр Иванов
2005-12-02 16:45
2005.12.25
Год спустя...


14-1133459980
Aleksandrrr
2005-12-01 20:59
2005.12.25
загрузочный диск


2-1134314526
Змей
2005-12-11 18:22
2005.12.25
свернуть и восстановить


14-1133431327
Knight
2005-12-01 13:02
2005.12.25
IRC - протокол...


3-1131016316
oleggar
2005-11-03 14:11
2005.12.25
Clipper