aksdb/restemplate
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

* Replaced fphttpclient with indy10.

Browse Source 
* Added compression support
This commit is contained in:
Andreas Schneider
2015-10-04 14:14:55 +02:00
parent 610c1e4108
commit b1e455022b
1330 changed files with 338589 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2778
indy/examples/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

13
indy/examples/Makefile.fpc Normal file
View File

@@ -0,0 +1,13 @@
[target]
dirs=httpget elizaweb
[require]
packages=indy
packagedir=../
[compiler]
unittargetdir=units/$(CPU_TARGET)-$(OS_TARGET)
options=-dUseCThreads -gl
[install]
fpcpackage=y

BIN
indy/examples/elizaweb/HTML/Eliza.jpg Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 2.9 KiB

50
indy/examples/elizaweb/HTML/eliza.html Normal file
View File

@@ -0,0 +1,50 @@
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN">
<HTML>
<HEAD>
<META HTTP-EQUIV="Content-Type" CONTENT="text/html;CHARSET=iso-8859-1">
<META NAME="GENERATOR" Content="Visual Page 1.1 for Windows">
<TITLE>Eliza Web</TITLE>
</HEAD>
<BODY BGCOLOR="#FFFFFF">
{%SOUND%}
<FORM ACTION="/eliza.html" METHOD="POST" ENCTYPE="application/x-www-form-urlencoded">
<CENTER>
<P></P>
<P><BR>
<BR>
<TABLE BORDER="0">
<TR>
<TD COLSPAN="3">
<P ALIGN="CENTER"><IMG SRC="logo.jpg" WIDTH="92" HEIGHT="34" ALIGN="BOTTOM" BORDER="0">
</TD>
</TR>
<TR>
<TD COLSPAN="3">
<P></P>
<P>Please tell me your thoughts:<BR>
<INPUT TYPE="TEXT" NAME="Thought" SIZE="50"></P>
<CENTER>
<P><INPUT TYPE="SUBMIT" NAME="Submit" VALUE="Ask Eliza">
</CENTER>
</TD>
</TR>
<TR>
<TD WIDTH="92"><IMG SRC="Eliza.jpg" WIDTH="92" HEIGHT="92" ALIGN="BOTTOM" BORDER="0"></TD>
<TD WIDTH="14">&nbsp;</TD>
<TD><FONT COLOR="#CC00FF"><I>{%RESPONSE%}</I></FONT></TD>
</TR>
</TABLE>
</P>
</CENTER>
<P>
<P>
</FORM>
</BODY>
</HTML>

49
indy/examples/elizaweb/HTML/index.html Normal file
View File

@@ -0,0 +1,49 @@
<HTML>
<HEAD>
<TITLE>Eliza Web</TITLE>
<meta name="vs_showGrid" content="True">
</HEAD>
<BODY BGCOLOR="#ffffff">
<P ALIGN="center"></P>
<P ALIGN="center">
<TABLE id="Table1" cellSpacing="1" cellPadding="1" width="300" border="1">
<TR>
<TD>
<P align="center"><IMG height="34" src="logo.jpg" width="92" align="bottom" border="0"></P>
<P align="center"></P>
<P align="center">I am Eliza. I am an E-Therapist, much cheaper than a real one and
just as effective!
</P>
<P align="center"><IMG height="92" src="Eliza.jpg" width="92" align="bottom" border="0">
</P>
<P align="center">I am also what you might call a schizophrenic therapist, or maybe
a chameleon therapist. That is I have multiple personalities that you can
choose from to fit your needs.</P>
<P align="center">Please choose one of my<BR>
personalities to proceed:</P>
<UL>
<LI>
<DIV align="left"><A href="eliza.html?Personality=Eliza">Eliza
the Therapist</A></DIV>
<LI>
<DIV align="left">Eliza the Therapist (Cranky)</DIV>
<LI>
<DIV align="left">Eliza the Therapist (Drunk)</DIV>
<LI>
<DIV align="left"><A href="eliza.html?Personality=Microsoft+Technical+Support">Microsoft Technical
Support</A></DIV>
<LI>
<DIV align="left"><A href="eliza.html?personality=Bill+Clinton">On the stand with Bill
Clinton</A></DIV>
<LI>
<DIV align="left">Press conference with Janet Reno</DIV>
</LI>
</UL>
</TD>
</TR>
</TABLE>
<BR>
<BR>
</P>
</BODY>
</HTML>

BIN
indy/examples/elizaweb/HTML/logo.jpg Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 2.0 KiB

2991
indy/examples/elizaweb/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

19
indy/examples/elizaweb/Makefile.fpc Normal file
View File

@@ -0,0 +1,19 @@
[target]
programs=elizaweb
implicitunits=ezBillClinton ezEliza \
ezEngine ezIFM \
ezMSTechSupport ezpersonality
[require]
packages=indy
packagedir=../../
[compiler]
unittargetdir=units/$(CPU_TARGET)-$(OS_TARGET)
#For some reason, we can't use "unitdir" here. It causes some strange bugs.
#This is a workaround.
options=-dUseCThreads -gl
[install]
fpcpackage=y
files=HTML/eliza.html HTML/Eliza.jpg \
HTML/index.html HTML/logo.jpg

157
indy/examples/elizaweb/elizaweb.pas Normal file
View File

@@ -0,0 +1,157 @@
program elizaweb;
{$ifdef fpc}
{$mode delphi}{$H+}
{$endif}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Classes,
ezBillClinton,
ezPersonality,
ezEliza,
ezEngine,
ezMSTechSupport,
IdBaseComponent,
IdComponent,
IdTCPServer,
IdCustomHTTPServer,
IdHTTPServer, IdContext, IdCustomTCPServer, IdSocketHandle, SysUtils;
type
TElizaWebProg = class(TObject)
protected
IdHTTPServer1: TIdHTTPServer;
FHTMLDir: string;
FTemplate: string;
//
procedure Ask(ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
procedure IdHTTPServer1SessionStart(Sender: TIdHTTPSession);
procedure IdHTTPServer1SessionEnd(Sender: TIdHTTPSession);
procedure IdHTTPServer1CommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo);
public
constructor Create;
destructor Destroy; override;
end;
constructor TElizaWebProg.Create;
var b : TIdSocketHandle;
begin
inherited Create;
idhttpserver1 := TIdHTTPServer.Create;
b:=idhttpserver1.Bindings.Add;
b.IP:='127.0.0.1';
b.port:=8000;
idhttpserver1.DefaultPort := 25000;
idhttpserver1.AutoStartSession := True;
idhttpserver1.ServerSoftware := 'Eliza Web';
idhttpserver1.SessionTimeOut := 600000;
idhttpserver1.OnSessionStart := IdHTTPServer1SessionStart;
idhttpserver1.OnSessionEnd := IdHTTPServer1SessionEnd;
idhttpserver1.OnCommandGet := IdHTTPServer1CommandGet;
idhttpserver1.SessionState := True;
idhttpserver1.active:=true;
FHTMLDir := ExtractFilePath(ParamStr(0)) + 'HTML';
with TFileStream.Create(includetrailingpathdelimiter(FHTMLDir)+ 'eliza.html', fmOpenRead) do try
SetLength(FTemplate, Size);
ReadBuffer(FTemplate[1], Size);
finally Free; end;
end;
destructor TElizaWebProg.Destroy;
begin
FreeAndNil(idhttpserver1);
inherited Destroy;
end;
procedure TElizaWebProg.IdHTTPServer1SessionStart(Sender: TIdHTTPSession);
begin
Sender.Content.AddObject('Eliza', TEZEngine.Create(nil));
end;
procedure TElizaWebProg.IdHTTPServer1SessionEnd(Sender: TIdHTTPSession);
begin
TEZEngine(Sender.Content.Objects[0]).Free;
end;
procedure TElizaWebProg.IdHTTPServer1CommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo);
var
LFilename: string;
LPathname: string;
begin
LFilename := ARequestInfo.Document;
if AnsiSameText(LFilename, '/eliza.html') then begin
Ask(ARequestInfo, AResponseInfo);
end else begin
if LFilename = '/' then begin
LFilename := '/index.html';
end;
LPathname := FHTMLDir + LFilename;
if FileExists(LPathname) then begin
AResponseInfo.ContentStream := TFileStream.Create(LPathname, fmOpenRead + fmShareDenyWrite);
end else begin
AResponseInfo.ResponseNo := 404;
AResponseInfo.ContentText := 'The requested URL ' + ARequestInfo.Document
+ ' was not found on this server.';
end;
end;
end;
procedure TElizaWebProg.Ask(ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
s: string;
LEliza: TEZEngine;
LPersonality: string;
LResponse: string;
LSound: string;
LQuestion: string;
begin
LResponse := '';
LEliza := TEZEngine(ARequestInfo.Session.Content.Objects[0]);
LPersonality := Trim(ARequestInfo.Params.Values['Personality']);
if LPersonality <> '' then begin
LEliza.SetPersonality(LPersonality);
end else begin
LQuestion := Trim(ARequestInfo.Params.Values['Thought']);
if LQuestion <> '' then begin
LResponse := LEliza.TalkTo(LQuestion, LSound);
end;
end;
if LEliza.Done then begin
AResponseInfo.ContentText := LResponse;
end else begin
s := FTemplate;
s := StringReplace(s, '{%RESPONSE%}', LResponse, []);
if LSound <> '' then begin
// I cannot distibute the wav files, they are from a commercial game, but I use
// them when showing the demo live.
if FileExists(FHTMLDir + '\' + LSound) then begin
LSound := '<BGSOUND SRC=' + LSound + '.wav>';
end else begin
LSound := '';
end;
end;
s := StringReplace(s, '{%SOUND%}', LSound, []);
AResponseInfo.ContentText := s;
end;
end;
var GProg : TElizaWebProg;
begin
GProg := TElizaWebProg.Create;
try
WriteLn('Eliza Demo now available at:');
WriteLn('');
WriteLn('http://127.0.0.1:8000/');
WriteLn('');
WriteLn('Press enter when finished');
ReadLn;
finally
FreeAndNil(GProg);
end;
end.

99
indy/examples/elizaweb/ezBillClinton.pas Normal file
View File

@@ -0,0 +1,99 @@
{ $HDR$}
{**********************************************************************
Unit archived using Team Coherence
Team Coherence is Copyright 2002 by Quality Software Components
For further information / comments, visit our WEB site at
http://www.TeamCoherence.com
**********************************************************************
$Log: 21824: EZBillClinton.pas
Rev 1.0 2003.07.13 12:12:00 AM czhower
Initial checkin
Rev 1.0 2003.05.19 2:54:10 PM czhower
}
unit ezBillClinton;
interface
{$ifdef fpc}
{$mode objfpc}{$H+}
{$endif}
uses
EZPersonality;
type
TPersonalityBillClinton = class(TEZPersonality)
protected
procedure InitReplies; override;
public
class function Attributes: TEZPersonalityAttributes; override;
end;
implementation
{ TPersonalityBillClinton }
class function TPersonalityBillClinton.Attributes: TEZPersonalityAttributes;
begin
with Result do begin
Name := 'Bill Clinton';
Description := 'Slick Willy himself';
end;
end;
procedure TPersonalityBillClinton.InitReplies;
begin
// Paula
AddReply([' sex '], [
'That is a personal subject and not appropriate for a president to speak about.'
, 'This is between Hillary and I.'
], [
'',
'Laugh'
]);
AddReply([' defensive '], [
'I am not being defensive.'
, 'Why are you picking on me?'
]);
AddReply([' Monica '], [
'She was a fine intern.'
, 'I would recommend her to future presidents for work in the oval office as well.'
, 'I am sorry but I cannot violate her client privelege confidentiality.'
, 'That has been classified as a state secret.'
, 'Did you hear the one about the quail, the bush and the tree?'
], [
'',
'OhYeah'
]);
AddReply([' whitewater '], [
'I do not know about that.'
, 'That was Hillary''s investment not mine.'
, 'I was not involved in that, you should speak to my wife.'
]);
AddReply([' Jennifer '], [
'That is old news.'
, 'Why do you insist on bringing up old issues?'
]);
AddReply([' Hillary '], [
'Hillary is not on trial here.'
, 'What Hillary does is her business.'
]);
AddReply([' Big Mac'], [
'Oh yeah. I like them.'
], [
'INeedFood'
]);
AddReply(['--NOKEYFOUND--'], [
'I am trying my hardest. But I do not understand what you are asking me.'
, 'I must consult with my lawyer before speaking on this.'
, 'I plead the fifth ammendment.'
, 'I choose not to answer that question on advise from my lawyer'
]);
end;
initialization
TPersonalityBillClinton.RegisterPersonality;
end.

223
indy/examples/elizaweb/ezEliza.pas Normal file
View File

@@ -0,0 +1,223 @@
{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence }
{ Team Coherence is Copyright 2002 by Quality Software Components }
{ }
{ For further information / comments, visit our WEB site at }
{ http://www.TeamCoherence.com }
{**********************************************************************}
{
$Log: 21826: EZEliza.pas
Rev 1.0 2003.07.13 12:12:00 AM czhower
Initial checkin
Rev 1.0 2003.05.19 2:54:14 PM czhower
}
unit ezEliza;
interface
{$ifdef fpc}
{$mode objfpc}{$H+}
{$endif}
uses
EZPersonality;
type
TPersonalityEliza = class(TEZPersonality)
protected
procedure InitReplies; override;
public
class function Attributes: TEZPersonalityAttributes; override;
end;
implementation
{ TPersonalityEliza }
class function TPersonalityEliza.Attributes: TEZPersonalityAttributes;
begin
with Result do begin
Name := 'Eliza';
Description := 'Original Eliza implementation.';
end;
end;
procedure TPersonalityEliza.InitReplies;
begin
// These are parsed in order - first one wins
// If no space before, it can be the end of a word
// If no space on either side, can be the middle of word
AddReply([' CAN YOU '], [
'Don''t you believe that I can *?'
, 'Perhaps you would like to be like me.'
, 'You want me to be able to *?'
]);
AddReply([' CAN I '], [
'Perhaps you don''t want to *?'
, 'Do you want to be able to *?'
]);
AddReply([' YOU ARE ', ' YOU''RE '], [
'What makes you think I am *?'
, 'Does it please you to believe I am *?'
, 'Perhaps you would like to be", *?'
, 'Do you sometimes wish you were *?'
]);
AddReply(['I DON''T '], [
'don''t you really *?'
, 'Why don''t you *?'
, 'Do you wish to be able to *?'
, 'Does that trouble you?'
]);
AddReply(['I FEEL '], [
'Do you often feel *?'
, 'Do you enjoy feeling *?'
]);
AddReply(['WHY DON''T YOU '], [
'Do you really believe I don''t *?'
, 'Perhaps in good time I will", *?'
, 'Do you want me to *?'
]);
AddReply(['WHY CAN''T I '], [
'Do you think you should be able to *?'
, 'Why can''t you *?'
]);
AddReply(['ARE YOU '], [
'Why are you interested in whether or not I am *?'
, 'Would you prefer if I were not *?'
, 'Perhaps in your fantasies I am", *?'
]);
AddReply(['I CAN''T ', 'I CANNOT', 'I CAN NOT'], [
'How do you know you can''t *?'
, 'Have you tried?'
, 'Perhaps you can now *.'
]);
AddReply(['I AM ', 'I''M'], [
'Did you come to me because you are *?'
, 'How long have you been *?'
, 'Do you believe it is normal to be *?'
, 'Do you enjoy being *?'
]);
AddReply(['YOU '], [
'We were discussing you--not me.'
, 'Oh, I ?'
, 'You''re not really talking about me, are you?'
]);
AddReply(['I WANT '], [
'What would it mean to you if you got *?'
, 'Why do you want *?'
, 'Suppose you soon got *?'
, 'What if you never got *?'
, 'I sometimes also want *?'
]);
AddReply(['WHAT ', 'HOW ', 'WHO ', 'WHERE ', 'WHEN ', 'WHY '], [
'Why do you ask?'
, 'Does that question interest you?'
, 'What answer would please you the most?'
, 'What do you think?'
, 'Are such questions on your mind often?'
, 'What is it that you really want to know?'
, 'Have you asked anyone else?'
, 'Have you asked such questions before?'
, 'What else comes to mind when you ask that?'
]);
AddReply(['NAME '], [
'Names don''t interest me.'
, 'I don''t care about names --please go on.'
]);
AddReply(['CAUSE '], [
'Is that the real reason?'
, 'don''t any other reasons come to mind?'
, 'Does that reason explain anything else?'
, 'What other reasons might there be?'
]);
AddReply(['SORRY '], [
'Please don''t apologize!'
, 'Apologies are not necessary.'
, 'What feelings do you have when you apologize?'
, 'don''t be so defensive!'
]);
AddReply(['DREAM '], [
'What does that dream suggest to you?'
, 'Do you dream often?'
, 'What persons appear in your dreams?'
, 'Are you disturbed by your dreams?'
]);
AddReply(['HELLO ', 'HI '], [
'How do you do ...please state your problem.'
]);
AddReply(['MAYBE '], [
'You don''t seem quite certain.'
, 'Why the uncertain tone?'
, 'can''t you be more positive?'
, 'You aren''t sure?'
, 'don''t you know?'
]);
AddReply(['NO '], [
'Are you saying no just to be negative?'
, 'You are being a bit negative.'
, 'Why not?'
, 'Are you sure?'
, 'Why no?'
]);
AddReply(['YOUR '], [
'Why are you concerned about my *?'
, 'What about your own *?'
]);
AddReply(['ALWAYS '], [
'Can you think of a specific example?'
, 'When?'
, 'What are you thinking of?'
, 'Really, always?'
]);
AddReply(['THINK '], [
'Do you really think so?'
, 'But you are not sure you, *?'
, 'Do you doubt you *?'
]);
AddReply(['ALIKE '], [
'In what way?'
, 'What resemblance do you see?'
, 'What does the similarity suggest to you?'
, 'What other connections do you see?'
, 'Could there really be some connection?'
, 'How?'
, 'You seem quite positive.'
]);
AddReply(['YES '], [
'Are you sure?'
, 'I see.'
, 'I understand.'
]);
AddReply(['FRIEND '], [
'Why do you bring up the topic of friends?'
, 'Do your friends worry you?'
, 'Do your friends pick on you?'
, 'Are you sure you have any friends?'
, 'Do you impose on your friends?'
, 'Perhaps your love for friends worries you.'
]);
AddReply(['COMPUTER'], [
'Do computers worry you?'
, 'Are you talking about me in particular?'
, 'Are you frightened by machines?'
, 'Why do you mention computers?'
, 'What do you think machines have to do with your problem?'
, 'don''t you think computers can help people?'
, 'What is it about machines that worries you?'
]);
AddReply(['--NOKEYFOUND--'], [
'Say, do you have any psychological problems?'
, 'What does that suggest to you?'
, 'I see.'
, 'I''m not sure I understand you fully.'
, 'Come come elucidate your thoughts.'
, 'Can you elaborate on that?'
, 'That is quite interesting.'
]);
end;
initialization
TPersonalityEliza.RegisterPersonality;
end.

197
indy/examples/elizaweb/ezEngine.pas Normal file
View File

@@ -0,0 +1,197 @@
{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence }
{ Team Coherence is Copyright 2002 by Quality Software Components }
{ }
{ For further information / comments, visit our WEB site at }
{ http://www.TeamCoherence.com }
{**********************************************************************}
{}
{ $Log: 21828: EZEngine.pas
Rev 1.0 2003.07.13 12:12:02 AM czhower
Initial checkin
Rev 1.0 2003.05.19 2:54:00 PM czhower
}
unit EZEngine;
interface
{$ifdef fpc}
{$mode objfpc}{$H+}
{$endif}
{
ELIZA -- an interactive parroting
Original Source: CREATIVE COMPUTING - MORRISTOWN, NEW JERSEY, late 1970's
Converted from Basic and some language called Inform to Delphi by
Chad Z. Hower aka Kudzu in 2002 - email: chad at hower dot org
Converted to objects, and implementation rewritten from scratch. Logic matched as best possible
but BASIC code also had bugs in logic. Inform version also differed slightly, but probaly more
accurate, but I am no Inform expert.
Since that time I have made several custom modifications an improvements including the addition
of personalities.
Note:
Because of the conversion from older languages, this is not my best code.
Slowly over time I am cleaning it up to make it more proper OO code. I am also
expanding its capabilities beyond its original design.
}
uses
Classes,
ezPersonality;
type
TEZEngine = class(TComponent)
protected
FConjugations: TStrings;
FDone: Boolean;
FLastMsg: string;
FPersonality: TEZPersonality;
//
procedure InitConjugations;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure SetPersonality(const AName: string);
function TalkTo(AMsg: string): string; overload;
function TalkTo(AMsg: string; var VSound: string): string; overload;
//
property Done: Boolean read FDone;
property Personality: TEZPersonality read FPersonality;
end;
implementation
uses
SysUtils, StrUtils;
{ TEZEngine }
constructor TEZEngine.Create(AOwner: TComponent);
begin
inherited;
FConjugations := TStringList.Create;
InitConjugations;
end;
destructor TEZEngine.Destroy;
begin
FreeAndNil(FPersonality);
FreeAndNil(FConjugations);
inherited;
end;
procedure TEZEngine.InitConjugations;
begin
with FConjugations do begin
Add('Are=am');
Add('Were=was');
Add('You=I');
Add('Your=my');
Add('I''ve=you''ve');
Add('I''m=you''re');
Add('Me=you');
end;
end;
procedure TEZEngine.SetPersonality(const AName: string);
begin
FreeAndNil(FPersonality);
FPersonality := TEZPersonality.ConstructPersonality(AName);
end;
function TEZEngine.TalkTo(AMsg: string; var VSound: string): string;
var
i, j: Integer;
s: string;
LConj: string;
LFoundKeyword: string;
LFoundKeywordIdx: Integer;
LFoundKeywordPos: Integer;
LKeyword: string;
LWordIn: string;
LWordOut: string;
begin
VSound := '';
if FPersonality = nil then begin
raise Exception.Create('No personality has been specified.');
end;
Result := '';
LConj := '';
LFoundKeyword := '';
LFoundKeywordIdx := FPersonality.Keywords.IndexOf('--NOKEYFOUND--');
LFoundKeywordPos := 0;
//
AMsg := ' ' + Trim(AMsg) + ' ';
AMsg := StringReplace(AMsg, '''', '', [rfReplaceAll]);
// TODO: Respond to ones with ?
// Replace with spaces so ' bug ' will match ' bug. ' etc.
AMsg := StringReplace(AMsg, '?', ' ', [rfReplaceAll]);
AMsg := StringReplace(AMsg, '!', ' ', [rfReplaceAll]);
AMsg := StringReplace(AMsg, '.', ' ', [rfReplaceAll]);
if AnsiSameText(AMsg, FLastMsg) then begin
Result := 'Please don''t repeat yourself.';
end else if AnsiContainsText(AMsg, 'SHUT ') then begin
Result := 'How would you like it if I told you to shut up? I am sorry but we cannot continue'
+ ' like this. Good bye.';
FDone := True;
end else if Trim(AMsg) = '' then begin
Result := 'I cannot help you if you do not talk to me.';
end else begin
FLastMsg := AMsg;
// Find Keyword
for i := 0 to FPersonality.Keywords.Count - 1 do begin
LKeyword := FPersonality.Keywords[i];
for j := 1 to Length(AMsg) - Length(LKeyword) + 1 do begin
if AnsiSameText(Copy(AMsg, j, Length(LKeyword)), LKeyword) then begin
LFoundKeywordIdx := i;
LFoundKeyword := LKeyword;
LFoundKeywordPos := j;
Break;
end;
// Break out of second loop
if LFoundKeyword <> '' then begin
Break;
end;
end;
end;
// Take part of string and conjugate it using the list of strings to be swapped
LConj := ' ' + RightStr(AMsg, Length(AMsg) - Length(LFoundKeyword) - LFoundKeywordPos + 1)
+ ' ';
for i := 0 to FConjugations.Count - 1 do begin
LWordIn := FConjugations.Names[i];
LWordOut := FConjugations.Values[LWordIn] + ' ';
LWordIn := LWordIn + ' ';
LConj := StringReplace(LConj, LWordIn, LWordOut, [rfReplaceAll, rfIgnoreCase]);
end;
// Only one space
if Copy(LConj, 1, 1) = ' ' then begin
Delete(LConj, 1, 1);
end;
LConj := StringReplace(LConj, '!', '', [rfReplaceAll]);
// Get reply
s := TEZReply(FPersonality.Keywords.Objects[LFoundKeywordIdx]).NextText;
VSound := TEZReply(FPersonality.Keywords.Objects[LFoundKeywordIdx]).Sound;
if AnsiPos('*', s) = 0 then begin
Result := s;
end else if Trim(LConj) = '' then begin
Result := 'You will have to elaborate more for me to help you.';
end else begin
Result := StringReplace(s, '*', LConj, [rfReplaceAll, rfIgnoreCase]);
end;
end;
end;
function TEZEngine.TalkTo(AMsg: string): string;
var
LSound: string;
begin
Result := TalkTo(AMsg, LSound);
end;
end.

195
indy/examples/elizaweb/ezIFM.pas Normal file
View File

@@ -0,0 +1,195 @@
{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence }
{ Team Coherence is Copyright 2002 by Quality Software Components }
{ }
{ For further information / comments, visit our WEB site at }
{ http://www.TeamCoherence.com }
{**********************************************************************}
{
$Log: 21830: EZIFM.pas
Rev 1.0 2003.07.13 12:12:02 AM czhower
Initial checkin
Rev 1.0 2003.05.19 3:47:44 PM czhower
Rev 1.0 2003.05.19 2:54:10 PM czhower
}
unit ezIFM;
interface
{$mode objfpc}{$H+}
uses
EZPersonality;
type
TPersonalityIFM = class(TEZPersonality)
protected
procedure InitReplies; override;
public
class function Attributes: TEZPersonalityAttributes; override;
end;
implementation
{ TPersonalityIFM }
class function TPersonalityIFM.Attributes: TEZPersonalityAttributes;
begin
with Result do begin
Name := 'Iraq Foreign Minister';
Description := 'I deny nothing!';
end;
end;
procedure TPersonalityIFM.InitReplies;
begin
(*
"because we will behead you all"
"These cowards have no morals. They have no shame about lying"
"We will slaughter them, Bush Jr. and his international gang of bastards!"
"They are like a snake and we are going to cut it in pieces."
"They do not even have control over themselves! Do not believe them!"
"They will be burnt. We are going to tackle them"
"We blocked them inside the city. Their rear is blocked"
"Desperate Americans"
"They want to deceive their people first because now they are in a very shabby situation."
"It's a small town [Umm Qasar], it has only a few docks... now they are in a trap"
"Iraqi forces are still in control of the city, and they are engaging in an attrition war with the enemy"
"Americans are now in disarray"
"Iraq will spread them even more and chop them up."
*)
AddReply([' airport '], [
'Today we slaughtered them in the airport. They are out of Saddam International Airport.'
, 'The force that was in the airport, this force was destroyed..'
, 'At Saddam Airport? Now that''''s just silly!.'
, 'We went into the airport and crushed them, we cleaned the WHOOOLE place out, they were slaughtered.'
, 'They are nowhere near the airport ..they are lost in the desert...they can not read a compass...they are retarded.'
]);
AddReply([' surrender ', ' prisoners '], [
'Those are not Iraqi soldiers at all. Where did they bring them from?'
]);
AddReply([' george ', ' bush '], [
'Bush, this man is a war criminal, and we will see that he is brought to trial.'
, 'The leader of the international criminal gang of bastards.'
, 'The insane little dwarf Bush.'
, 'Bush is a very stupid man. The American people are not stupid, they are very clever. I can''''t understand how such clever people came to elect such a stupid president.'
, 'Bush doesn''''t even know if Spain is a republic or a kingdom, how can they follow this man?'
, 'Bush, Blair and Rumsfeld. They are the funny trio.'
, 'This criminal in the White House is a stupid criminal.'
]);
AddReply([' tony ', ' blair ', ' britain ', ' uk ', ' british '], [
'Bush, Blair and Rumsfeld. They are the funny trio.'
, 'Britain is not worth an old shoe.'
, 'I think the British nation has never been faced with a tragedy like this fellow Blair.'
]);
AddReply([' american ', ' americans ', ' troops ', ' soldiers '], [
'They are again in the dirt in the desert.'
, 'We besieged them and killed most of them, and I think we will finish them soon.'
, 'Their casualties and bodies are many.'
, 'We feed them death and hell!'
, 'Let the American infidels bask in their illusion.'
, 'We have given them a sour taste.'
, 'They are most welcome. We will butcher them..'
, 'We will welcome them with bullets and shoes.'
, 'We have placed them in a quagmire from which they can never emerge except dead.'
, 'Washington has thrown their soldiers on the fire.'
, 'We will kill them all........most of them..'
]);
AddReply([' tommy ', ' franks '], [
'Who is this dog Franks in Qatar?'
, 'Idiot.'
]);
AddReply([' you '], [
'What do I have to do with this?'
, 'Why ask me?'
, 'You should ask yourself that question!'
]);
AddReply([' your '], [
'I don''''t know anything about any *'
, 'What *'
]);
AddReply([' helicoptor ', ' helicoptors '], [
'We have destroyed 2 tanks, fighter planes, 2 helicopters and their shovels - We have driven them back.'
, 'Our farmers, they are targeting accurately the enemy.'
]);
AddReply([' un ', ' united nations '], [
'The United Nations is a place for prostitution under the feet of Americans.'
]);
AddReply([' donald ', ' rumsfield '], [
'The midget Bush and that Rumsfield deserve only to be beaten with shoes by freedom loving people everywhere.'
, 'Rumsfeld, he needs to be hit on the head.'
, 'Yesterday we heard this villain called Rumsfeld. He, of course, is a war criminal.'
, 'Bush, Blair and Rumsfeld. They are the funny trio.'
, 'Rumsfeld is a crook and the most despicable creature.'
, 'Rumsfeld is the worst kind of bastard.'
]);
AddReply([' feel ', ' think '], [
'My feelings - as usual - we will slaughter them all.'
, 'Our initial assessment is that they will all die.'
, 'God will roast their stomachs in hell at the hands of Iraqis.'
]);
AddReply([' scared '], [
'No I am not scared, and neither should you be!.'
]);
AddReply([' baghdad '], [
'There are no American infidels in Baghdad. Never!'
, 'Be assured. Baghdad is safe, protected.'
, 'We will see how the issue will turn out when they come to Baghdad.'
, 'I triple guarantee you, there are no American soldiers in Baghdad.'
, 'They''''re not even within 100 miles.'
, 'They are nowhere near Baghdad. Their allegations are a cover-up for their failure.'
, 'They will try to enter Baghdad, and I think this is where their graveyard will be.'
, 'Their objective is to get to the outskirts of Baghdad. So be it.'
]);
AddReply([' tanks ', ' tank '], [
'We have them surrounded in their tanks.'
, 'They''''re coming to surrender or be burned in their tanks.'
, 'We have destroyed 2 tanks, fighter planes, 2 helicopters and their shovels - We have driven them back.'
, 'There are only two American tanks in the city.'
]);
AddReply([' television ', ' media ', ' newspaper ', ' press '], [
'I blame Al-Jazeera - they are marketing for the Americans!'
, 'The American press is all about lies! All they tell is lies, lies and more lies!'
]);
AddReply(['--NOKEYFOUND--'], [
'I speak better English than this villain Bush.'
, 'We are winning!'
, 'Blood-sucking bastards.'
, 'This is unbased.'
, 'The louts of colonialism.'
, 'I will only answer reasonable questions.'
, 'Don''''t believe anything! We will chase the rascals back to London!'
]);
end;
initialization
TPersonalityIFM.RegisterPersonality;
end.

82
indy/examples/elizaweb/ezMSTechSupport.pas Normal file
View File

@@ -0,0 +1,82 @@
{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence }
{ Team Coherence is Copyright 2002 by Quality Software Components }
{ }
{ For further information / comments, visit our WEB site at }
{ http://www.TeamCoherence.com }
{**********************************************************************}
{
$Log: 21832: EZMSTechSupport.pas
Rev 1.0 2003.07.13 12:12:04 AM czhower
Initial checkin
Rev 1.0 2003.05.19 2:54:20 PM czhower
}
unit ezMSTechSupport;
interface
{$ifdef fpc}
{$mode objfpc}{$H+}
{$endif}
uses
EZPersonality;
type
TPersonalityMSTechSupport = class(TEZPersonality)
protected
procedure InitReplies; override;
public
class function Attributes: TEZPersonalityAttributes; override;
end;
implementation
{ TPersonalityMSTechSupport }
class function TPersonalityMSTechSupport.Attributes: TEZPersonalityAttributes;
begin
with Result do begin
Name := 'Microsoft Technical Support';
Description := 'Dont pay $5 a minute, get the SAME level of suppor for'
+ ' free!';
end;
end;
procedure TPersonalityMSTechSupport.InitReplies;
begin
AddReply([' My problem is ', ' The problem is '], [
'So you are calling about *?'
, 'Is * a problem?'
]);
AddReply([' crashes when I ', ' crashes when ', ' crashing when '], [
'The obvious answer would be not to *'
, 'You are just asking for trouble.'
]);
AddReply([' bug '], [
'Are you sure thats a bug?'
, 'Thats not a bug, its a feature.'
]);
AddReply([' AV ', ' AVs ', ' Access violation ', ' crash ', ' BSOD '], [
'I am sorry but I cannot reproduce that problem here.'
, 'It works fine here. The problem must be on your end.'
, 'Hmm. I have never heard of a problem like that.'
, 'Have you tried rebooting your system?'
, 'Do you have all the service packs installed?'
]);
AddReply([' Borland ', ' Delphi '], [
'Is Borland still around?'
, 'The problem is probably with the Borland product. You should contact Borland.'
, 'I am sorry but we do not support Borland products.'
]);
AddReply(['--NOKEYFOUND--'], [
'I will need more information.'
, 'I will need to ask my supervisor for help.'
]);
end;
initialization
TPersonalityMSTechSupport.RegisterPersonality;
end.

178
indy/examples/elizaweb/ezpersonality.pas Normal file
View File

@@ -0,0 +1,178 @@
{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence }
{ Team Coherence is Copyright 2002 by Quality Software Components }
{ }
{ For further information / comments, visit our WEB site at }
{ http://www.TeamCoherence.com }
{**********************************************************************}
{
$Log: 21834: EZPersonality.pas
Rev 1.0 2003.07.13 12:12:04 AM czhower
Initial checkin
Rev 1.0 2003.05.19 2:54:06 PM czhower
}
unit ezpersonality;
interface
{$ifdef fpc}
{$mode objfpc}{$H+}
{$endif}
uses
Classes;
type
TEZPersonalityAttributes = record
Name: string;
Description: string;
end;
TEZPersonality = class;
TEZPersonalityClass = class of TEZPersonality;
TEZPersonality = class(TCollection)
protected
FKeywords: TStrings;
//
procedure AddReply(const AKeywords: array of string;
const AReplies: array of string); overload;
procedure AddReply(const AKeywords: array of string;
const AReplies: array of string; const ASounds: array of string); overload;
procedure InitReplies; virtual; abstract;
public
class function Attributes: TEZPersonalityAttributes; virtual; abstract;
class function ConstructPersonality(const AName: string): TEZPersonality;
constructor Create; virtual;
destructor Destroy; override;
class procedure PersonalityList(AStrings: TStrings);
class procedure RegisterPersonality;
//
property Keywords: TStrings read FKeywords;
end;
TEZReply = class(TCollectionItem)
protected
FIndex: Integer;
FSound: string;
FSounds: TStrings;
FTexts: TStrings;
public
procedure AddText(const AText: string; const ASound: string = '');
constructor Create(AOwner: TCollection); override;
destructor Destroy; override;
function NextText: string;
//
property Sound: string read FSound;
end;
implementation
uses
SysUtils;
var
GPersonalities: TStringList;
{ TEZReply }
procedure TEZReply.AddText(const AText: string; const ASound: string = '');
begin
FTexts.Add(AText);
FSounds.Add(ASound);
end;
constructor TEZReply.Create(AOwner: TCollection);
begin
inherited;
FSounds := TStringList.Create;
FTexts := TStringList.Create;
end;
destructor TEZReply.Destroy;
begin
FreeAndNil(FTexts);
FreeAndNil(FSounds);
inherited;
end;
function TEZReply.NextText: string;
begin
Result := FTexts[FIndex];
FSound := FSounds[FIndex];
Inc(FIndex);
if FIndex = FTexts.Count then begin
FIndex := 0;
end;
end;
{ TEZPersonality }
procedure TEZPersonality.AddReply(const AKeywords, AReplies: array of string;
const ASounds: array of string);
var
i: integer;
LReply: TEZReply;
begin
LReply := TEZReply.Create(Self);
for i := Low(AReplies) to High(AReplies) do begin
if i <= High(ASounds) then begin
LReply.AddText(AReplies[i], ASounds[i]);
end else begin
LReply.AddText(AReplies[i]);
end;
end;
for i := Low(AKeywords) to High(AKeywords) do begin
FKeywords.AddObject(Uppercase(AKeywords[i]), LReply);
end;
end;
procedure TEZPersonality.AddReply(const AKeywords, AReplies: array of string);
begin
AddReply(AKeywords, AReplies, []);
end;
class function TEZPersonality.ConstructPersonality(
const AName: string): TEZPersonality;
var
i: Integer;
begin
i := GPersonalities.IndexOf(AName);
if i = -1 then begin
raise Exception.Create('Personality not found.');
end;
Result := TEZPersonalityClass(GPersonalities.Objects[i]).Create;
end;
constructor TEZPersonality.Create;
begin
inherited Create(TEZReply);
FKeywords := TStringList.Create;
InitReplies;
end;
destructor TEZPersonality.Destroy;
begin
FreeAndNil(FKeywords);
inherited;
end;
class procedure TEZPersonality.PersonalityList(AStrings: TStrings);
begin
AStrings.AddStrings(GPersonalities);
end;
class procedure TEZPersonality.RegisterPersonality;
begin
GPersonalities.AddObject(Self.Attributes.Name, TObject(Self));
end;
initialization
GPersonalities := TStringList.Create;
GPersonalities.Sorted := True;
finalization
FreeAndNil(GPersonalities)
end.

2874
indy/examples/httpget/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

15
indy/examples/httpget/Makefile.fpc Normal file
View File

@@ -0,0 +1,15 @@
[target]
programs=httpget
implicitunits=httpprothandler ftpprothandler prothandler
[require]
packages=indy
packagedir=../../
[compiler]
unittargetdir=units/$(CPU_TARGET)-$(OS_TARGET)
#For some reason, we can't use "unitdir" here. It causes some strange bugs.
#This is a workaround.
options=-dUseCThreads -gl
[install]
fpcpackage=y

351
indy/examples/httpget/ftpprothandler.pas Normal file
View File

@@ -0,0 +1,351 @@
unit ftpprothandler;
{$IFDEF FPC}
{$mode delphi}{$H+}
{$ENDIF}
interface
uses
{$IFNDEF NO_FTP}
IdFTP,
IdFTPList, //for some diffinitions with FTP list
IdAllFTPListParsers, //with FTP, this links in all list parsing classes.
IdFTPListParseTandemGuardian, //needed ref. to TIdTandemGuardianFTPListItem property
IdFTPListTypes, //needed for ref. to TIdUnixBaseFTPListItem property
IdFTPListParseVMS, //needed for ref. to TIdVMSFTPListItem property ;
IdIOHandler,
IdTCPConnection,
IdIOHandlerStack,
{$ifdef usezlib}
IdCompressorZLib, //for deflate FTP support
{$endif}
IdLogEvent, //for logging component
{$ENDIF}
prothandler,
Classes, SysUtils, IdURI;
{$IFDEF VER200}
{$DEFINE STRING_IS_UNICODE} // 'String' type is Unicode now
{$ENDIF}
{$IFDEF VER210}
{$DEFINE STRING_IS_UNICODE} // 'String' type is Unicode now
{$ENDIF}
{$IFDEF VER220}
{$DEFINE STRING_IS_UNICODE} // 'String' type is Unicode now
{$ENDIF}
type
TFTPProtHandler = class(TProtHandler)
protected
FPort : Boolean;
{$IFNDEF NO_FTP}
procedure OnSent(ASender: TComponent; const AText: string; const AData: string);
procedure OnReceived(ASender: TComponent; const AText: string; const AData: string);
procedure MakeHTMLDirTable(AURL : TIdURI; AFTP : TIdFTP);
procedure OnDataChannelCreating(ASender: TObject; ADataChannel: TIdTCPConnection);
procedure OnDataChannelDestroy(ASender: TObject; ADataChannel: TIdTCPConnection);
procedure OnDirParseStart(ASender : TObject);
procedure OnDirParseEnd(ASender : TObject);
{$ENDIF}
public
class function CanHandleURL(AURL : TIdURI) : Boolean; override;
procedure GetFile(AURL : TIdURI); override;
constructor Create;
property Port : Boolean read FPort write FPort;
end;
implementation
uses IdGlobal;
class function TFTPProtHandler.CanHandleURL(AURL : TIdURI) : Boolean;
begin
{$IFDEF NO_FTP}
Result := False;
{$ELSE}
Result := UpperCase(AURL.Protocol)='FTP';
{$ENDIF}
end;
constructor TFTPProtHandler.Create;
begin
inherited Create;
FPort := False;
end;
procedure TFTPProtHandler.GetFile(AURL : TIdURI);
{$IFDEF NO_FTP}
begin
{$ELSE}
//In this procedure, URL handling has to be done manually because the
//the FTP component does not handle URL's at all.
var
LStr : TMemoryStream;
LIO : TIdIOHandlerStack;
LF : TIdFTP;
LDI : TIdLogEvent;
{$ifdef usezlib}
LC : TIdCompressorZLib;
{$endif}
LIsDir : Boolean;
i : Integer;
begin
LIsDir := False;
LDI := TIdLogEvent.Create;
LF := TIdFTP.Create;
{$ifdef usezlib}
LC := TIdCompressorZLib.Create;
if LC.IsReady then begin
LF.Compressor := LC;
end;
{$endif}
try
LDI.Active := True;
LDI.LogTime := False;
LDI.ReplaceCRLF := False;
LDI.OnReceived := OnReceived;
LDI.OnSent := OnSent;
LIO := TIdIOHandlerStack.Create;
LIO.Intercept := LDI;
LF.IOHandler := LIO;
LF.Passive := not FPort;
LF.UseMLIS := True;
LF.Host := AURL.Host;
LF.Password := AURL.URLDecode(AURL.Password);
LF.Username := AURL.URLDecode(AURL.Username);
LF.IPVersion := AURL.IPVersion;
LF.Password := AURL.Password;;
if LF.Username = '' then
begin
LF.Username := 'anonymous';
LF.Password := 'pass@httpget';
end;
if AURL.Document = '' then
begin
LIsDir := True;
end;
LStr := TMemoryStream.Create;
if FVerbose then begin
LF.OnDataChannelCreate := OnDataChannelCreating;
LF.OnDataChannelDestroy := OnDataChannelDestroy;
LF.OnDirParseStart := OnDirParseStart;
LF.OnDirParseEnd := OnDirParseEnd;
end;
LF.Connect;
try
LF.ChangeDir(AURL.Path);
//The thing is you can't always know if it's a file or dir.
if not LIsDir then
try
LF.Get(AURL.Document,LStr,True);
LStr.SaveToFile(AURL.Document);
except
LIsDir := True;
end;
if LIsDir then
begin
LF.List;
if FVerbose then
begin
for i := 0 to LF.ListResult.Count -1 do
begin
WriteLn({$IFDEF FPC}stdout{$ELSE}output{$ENDIF},LF.ListResult[i]);
end;
end;
MakeHTMLDirTable(AURL,LF);
end;
finally
LF.Disconnect;
FreeAndNil(LStr);
end;
finally
FreeAndNil(LF);
{$ifdef usezlib}
FreeAndNil(LC);
{$endif}
FreeAndNil(LIO);
FreeAndNil(LDI);
end;
{$ENDIF}
end;
{$IFNDEF NO_FTP}
procedure TFTPProtHandler.MakeHTMLDirTable(AURL : TIdURI; AFTP : TIdFTP);
{
This routine is in this demo to show users how to use the directory listing from TIdFTP.
}
var i : integer;
LTbl : TStringList;
LTmp : String;
procedure WriteTableCell(const ACellText : String; AOutput : TStrings);
begin
if ACellText = '' then
begin
AOutput.Add(' <TD>&nbsp;</TD>');
end
else
begin
AOutput.Add(' <TD>'+ACellText+'</TD>');
end;
end;
procedure MakeFileNameLink(const AURL :TIdURI; AFileName : String; AOutput : TStrings);
begin
if AURL.URI <>'' then
begin
if AURL.Document = '' then
begin
AOutput.Add(' <TD><A HREF="'+AURL.URI+'/'+AFileName+'">'+AFileName+'</A></TD>');
end
else
begin
AOutput.Add(' <TD><A HREF="'+AURL.URI +AFileName+'>'+AFileName+'</A></TD>');
end;
end
else
begin
WriteTableCell(AFileName,AOutput);
end;
end;
begin
LTbl := TStringList.Create;
try
LTbl.Add('<HTML>');
LTbl.Add(' <TITLE>'+AURL.URI+'</TITLE>');
{$IFDEF STRING_IS_UNICODE}
LTbl.Add(' <HEAD>');
LTbl.Add(' <meta http-equiv="Content-Type" content="text/html;charset=utf-8" >');
LTbl.Add(' </HEAD>');
{$ENDIF}
LTbl.Add(' <BODY>');
LTbl.Add(' <TABLE>');
LTbl.Add(' <TR>');
LTbl.Add(' <TH>Name</TH>');
LTbl.Add(' <TH>Type</TH>');
LTbl.Add(' <TH>Size</TH>');
LTbl.Add(' <TH>Date</TH>');
LTbl.Add(' <TH>Permissions</TH>');
LTbl.Add(' <TH>Owner</TH>');
LTbl.Add(' <TH>Group</TH>');
LTbl.Add(' </TR>');
for i := 0 to AFTP.DirectoryListing.Count - 1 do
begin
LTbl.Add(' <TR>');
//we want the name hyperlinked to it's location so a user can click on it in a browser
//to retreive a file.
MakeFileNameLink(AURL,AFTP.DirectoryListing[i].FileName,LTbl);
case AFTP.DirectoryListing[i].ItemType of
ditDirectory : LTmp := 'Directory';
ditFile : LTmp := 'File';
ditSymbolicLink, ditSymbolicLinkDir : LTmp := 'Symbolic link';
ditBlockDev : LTmp := 'Block Device';
ditCharDev : LTmp := 'Char Device';
ditFIFO : LTmp := 'Pipe';
ditSocket : LTmp := 'Socket';
end;
WriteTableCell(LTmp,LTbl);
//Some dir formats will not return a file size or will only do so in some cases.
if AFTP.DirectoryListing[i].SizeAvail then
begin
WriteTableCell(IntToStr(AFTP.DirectoryListing[i].Size),LTbl);
end
else
begin
WriteTableCell('',LTbl);
end;
//Some dir formats will not return a file date or will only do so in some cases.
if AFTP.DirectoryListing[i].ModifiedAvail then
begin
WriteTableCell(DateTimeToStr(AFTP.DirectoryListing[i].Size),LTbl);
end
else
begin
WriteTableCell('',LTbl);
end;
WriteTableCell(AFTP.DirectoryListing[i].PermissionDisplay,LTbl);
//get owner name
if AFTP.DirectoryListing[i] is TIdOwnerFTPListItem then
begin
WriteTableCell(TIdOwnerFTPListItem(AFTP.DirectoryListing[i]).OwnerName,LTbl);
end
else
begin
WriteTableCell('',LTbl);
end;
//now get group name
if AFTP.DirectoryListing[i] is TIdTandemGuardianFTPListItem then
begin
WriteTableCell(TIdTandemGuardianFTPListItem(AFTP.DirectoryListing[i]).GroupName,LTbl);
end;
if AFTP.DirectoryListing[i] is TIdUnixBaseFTPListItem then
begin
WriteTableCell(TIdUnixBaseFTPListItem(AFTP.DirectoryListing[i]).GroupName,LTbl);
end;
if AFTP.DirectoryListing[i] is TIdVMSFTPListItem then
begin
WriteTableCell(TIdVMSFTPListItem(AFTP.DirectoryListing[i]).GroupName,LTbl);
end;
LTbl.Add(' </TR>');
end;
LTbl.Add(' </TABLE>');
LTbl.Add(' </BODY>');
LTbl.Add('</HTML>');
{$IFDEF STRING_IS_UNICODE}
LTbl.SaveToFile('index.html', TEncoding.UTF8)
{$ELSE}
LTbl.SaveToFile('index.html');
{$ENDIF}
finally
FreeAndNil(LTbl);
end;
end;
procedure TFTPProtHandler.OnSent(ASender: TComponent; const AText: string; const AData: string);
var LData : String;
begin
LData := AData;
if TextStartsWith(LData,'PASS ') then begin
FLogData.Text := FLogData.Text + 'PASS ****';
end;
FLogData.Text := FLogData.Text + LData;
if FVerbose then begin
Write({$IFDEF FPC}stdout{$ELSE}output{$ENDIF},LData);
end;
end;
procedure TFTPProtHandler.OnDataChannelCreating(ASender: TObject;
ADataChannel: TIdTCPConnection);
begin
WriteLn({$IFDEF FPC}stdout{$ELSE}output{$ENDIF},'Opening Data Channel');
end;
procedure TFTPProtHandler.OnDataChannelDestroy(ASender: TObject;
ADataChannel: TIdTCPConnection);
begin
WriteLn({$IFDEF FPC}stdout{$ELSE}output{$ENDIF},'Closing Data Channel');
end;
procedure TFTPProtHandler.OnDirParseEnd(ASender: TObject);
begin
WriteLn({$IFDEF FPC}stdout{$ELSE}output{$ENDIF},'DIR Parsing finished');
end;
procedure TFTPProtHandler.OnDirParseStart(ASender: TObject);
begin
WriteLn('Dir Parsing Started');
end;
procedure TFTPProtHandler.OnReceived(ASender: TComponent; const AText: string; const AData: string);
begin
FLogData.Text := FLogData.Text + AData;
if FVerbose then
begin
Write({$IFDEF FPC}stdout{$ELSE}output{$ENDIF},AData);
end;
end;
{$ENDIF}
end.

114
indy/examples/httpget/httpget.pas Normal file
View File

@@ -0,0 +1,114 @@
program httpget;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
prothandler,
ftpprothandler,
httpprothandler,
Classes
{ add your units here },
IdGlobal, //for some helper functions I like
IdURI,
SysUtils;
procedure PrintHelpScreen;
var LExe : String;
begin
LExe := ExtractFileName(ParamStr(0));
WriteLn(LExe);
WriteLn('');
WriteLn('usage: '+LExe+' [-v] URL');
WriteLn('');
WriteLn(' v : Verbose');
end;
var
GURL : TIdURI;
i : Integer;
LP : TProtHandler;
//program defaults
GVerbose : Boolean;
GHelpScreen : Boolean;
GFTPPort : boolean;
const
GCmdOpts : array [0..5] of string=('-h','--help','-v','--verbose','-P','--port');
begin
GFTPPort := False;
GHelpScreen := False;
GVerbose := False;
LP := nil;
GURL := TIdURI.Create;
try
if ParamCount > 0 then
begin
for i := 1 to ParamCount do
begin
if Copy(ParamStr(i),1,1) = '-' then
begin
WriteLn(ParamStr(i));
case PosInStrArray(ParamStr(i),GCmdOpts) of
0, 1 : begin
GHelpScreen := True;
break;
end;
2, 3 : GVerbose := True;
4, 5 : GFTPPort := True;
end;
end
else
begin
GURL.URI := ParamStr(i);
end;
end;
end
else
begin
GHelpScreen := True;
end;
WriteLn(GURL.URI);
if (GURL.URI = '') or GHelpScreen then
begin
GHelpScreen := True;
end
else
begin
try
if THTTPProtHandler.CanHandleURL(GURL) then
begin
LP := THTTPProtHandler.Create;
LP.Verbose := GVerbose;
LP.GetFile(GURL);
end
else
begin
if TFTPProtHandler.CanHandleURL(GURL) then
begin
LP := TFTPProtHandler.Create;
LP.Verbose := GVerbose;
TFTPProtHandler(LP).Port := GFTPPort;
LP.GetFile(GURL);
end;
end;
finally
FreeAndNil(LP);
end;
end;
finally
FreeAndNil(GURL);
end;
if GHelpScreen then
begin
PrintHelpScreen;
end;
end.

196
indy/examples/httpget/httpprothandler.pas Normal file
View File

@@ -0,0 +1,196 @@
unit httpprothandler;
interface
{$IFDEF FPC}
{$mode delphi}{$H+}
{$ENDIF}
{$ifdef unix}
{$define usezlib}
{$define useopenssl}
{$endif}
{$IFDEF POSIX}
{$define usezlib}
{$define useopenssl}
{$ENDIF}
{$ifdef win32}
{$define usezlib}
{$define useopenssl}
{$endif}
{$ifdef win64}
{$define usezlib}
{$define useopenssl}
{$endif}
uses
{$IFNDEF NO_HTTP}
{$ifdef usezlib}
IdCompressorZLib, //for deflate and gzip content encoding
{$endif}
IdAuthenticationDigest, //MD5-Digest authentication
{$ifdef useopenssl}
IdSSLOpenSSL, //ssl
IdAuthenticationNTLM, //NTLM - uses OpenSSL libraries
{$endif}
Classes, SysUtils,
IdHTTPHeaderInfo, //for HTTP request and response info.
IdHTTP,
{$ENDIF}
prothandler,
IdURI;
type
THTTPProtHandler = class(TProtHandler)
protected
{$IFNDEF NO_HTTP}
function GetTargetFileName(AHTTP : TIdHTTP; AURI : TIdURI) : String;
{$ENDIF}
public
class function CanHandleURL(AURL : TIdURI) : Boolean; override;
procedure GetFile(AURL : TIdURI); override;
end;
implementation
class function THTTPProtHandler.CanHandleURL(AURL : TIdURI) : Boolean;
begin
{$IFNDEF NO_HTTP}
Result := UpperCase(AURL.Protocol)='HTTP';
{$ifdef useopenssl}
if not Result then
begin
Result := UpperCase(AURL.Protocol)='HTTPS';
end;
{$endif}
{$ELSE}
Result := False;
{$ENDIF}
end;
procedure THTTPProtHandler.GetFile(AURL : TIdURI);
{$IFNDEF NO_HTTP}
var
{$ifdef useopenssl}
LIO : TIdSSLIOHandlerSocketOpenSSL;
{$endif}
LHTTP : TIdHTTP;
LStr : TMemoryStream;
i : Integer;
LHE : EIdHTTPProtocolException;
LFName : String;
{$ifdef usezlib}
LC : TIdCompressorZLib;
{$endif}
begin
{$ifdef useopenssl}
LIO := TIdSSLIOHandlerSocketOpenSSL.Create;
{$endif}
{$ifdef usezlib}
LC := TIdCompressorZLib.Create;
{$endif}
try
LHTTP := TIdHTTP.Create;
try
{$ifdef useopenssl}
LHTTP.Compressor := LC;
{$endif}
//set to false if you want this to simply raise an exception on redirects
LHTTP.HandleRedirects := True;
{
Note that you probably should set the UserAgent because some servers now screen out requests from
our default string "Mozilla/3.0 (compatible; Indy Library)" to prevent address harvesters
and Denial of Service attacks. SOme people have used Indy for these.
Note that you do need a Mozilla string for the UserAgent property. The format is like this:
Mozilla/4.0 (compatible; MyProgram)
}
LHTTP.Request.UserAgent := 'Mozilla/4.0 (compatible; httpget)';
LStr := TMemoryStream.Create;
{$ifdef useopenssl}
LHTTP.IOHandler := LIO;
{$endif}
for i := 0 to LHTTP.Request.RawHeaders.Count -1 do
begin
FLogData.Add(LHTTP.Request.RawHeaders[i]);
if FVerbose then
begin
WriteLn({$IFDEF FPC}stdout{$ELSE}output{$ENDIF},LHTTP.Request.RawHeaders[i]);
end;
end;
LHTTP.Get(AURL.URI,LStr);
for i := 0 to LHTTP.Response.RawHeaders.Count -1 do
begin
FLogData.Add(LHTTP.Response.RawHeaders[i]);
if FVerbose then
begin
WriteLn({$IFDEF FPC}stdout{$ELSE}output{$ENDIF},LHTTP.Response.RawHeaders[i]);
end;
end;
LFName := GetTargetFileName(LHTTP,AURL);
if LFName <> '' then
begin
LStr.SaveToFile(LFName);
end;
except
on E : Exception do
begin
if E is EIdHTTPProtocolException then
begin
LHE := E as EIdHTTPProtocolException;
WriteLn({$IFDEF FPC}stderr{$ELSE}ErrOutput {$ENDIF},'HTTP Protocol Error - '+IntToStr(LHE.ErrorCode));
WriteLn({$IFDEF FPC}stderr{$ELSE}ErrOutput {$ENDIF},LHE.ErrorMessage);
if Verbose = False then
begin
for i := 0 to FLogData.Count -1 do
begin
Writeln({$IFDEF FPC}stderr{$ELSE}ErrOutput {$ENDIF},FLogData[i]);
end;
end;
end
else
begin
Writeln({$IFDEF FPC}stderr{$ELSE}ErrOutput {$ENDIF},E.Message);
end;
end;
end;
FreeAndNil(LHTTP);
FreeAndNil(LStr);
finally
{$ifdef useopenssl}
FreeAndNil(LIO);
{$endif}
{$ifdef usezlib}
FreeAndNil(LC);
{$endif}
end;
{$ELSE}
begin
{$ENDIF}
end;
{$IFNDEF NO_HTTP}
function THTTPProtHandler.GetTargetFileName(AHTTP : TIdHTTP; AURI : TIdURI) : String;
begin
{
We do things this way in case the server gave you a specific document type
in response to a request.
eg.
Request: http://www.indyproject.org/
Response: http://www.indyproject.org/index.html
}
if AHTTP.Response.Location <> '' then
begin
AURI.URI := AHTTP.Response.Location;
end;
Result := AURI.Document;
if Result = '' then
begin
Result := 'index.html';
end;
end;
{$ENDIF}
end.

51
indy/examples/httpget/prothandler.pas Normal file
View File

@@ -0,0 +1,51 @@
unit prothandler;
interface
{$IFDEF FPC}
{$mode delphi}{$H+}
{$ENDIF}
uses
{$IFDEF UNIX}
{$define usezlib}
{$define useopenssl}
{$ENDIF}
{$IFDEF POSIX}
{$define usezlib}
{$define useopenssl}
{$ENDIF}
{$IFDEF WIN32}
{$define usezlib}
{$define useopenssl}
{$ENDIF}
{$IFDEF WIN64}
{$define usezlib}
{$define useopenssl}
{$ENDIF}
Classes, SysUtils, IdURI;
type
TProtHandler = class(TObject)
protected
FLogData : TStrings;
FVerbose : Boolean;
public
constructor Create;
destructor Destroy; override;
class function CanHandleURL(AURL : TIdURI) : Boolean; virtual; abstract;
procedure GetFile(AURL : TIdURI); virtual; abstract;
property LogData : TStrings read FLogData;
property Verbose : Boolean read FVerbose write FVerbose;
end;
implementation
constructor TProtHandler.Create;
begin
inherited Create;
FLogData := TStringList.Create;
end;
destructor TProtHandler.Destroy;
begin
FreeAndNil(FLogData);
end;
end.