1:

Syncronize( procedure begin {do something} end );                    

1:

Queue(procedure begin {do something} end);                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:

var
  TestNumber: Integer;

procedure Test;
var
  TestVar: PInteger;
begin
  TestVar := @TestNumber;
  TestVar^ := 1;
  TThread.Queue(nil, procedure
    begin
      ShowMessage(IntToStr(TestVar^)); // gibt 2 aus
    end);
  TestVar^ := 2;
end;

procedure TForm259.FormCreate(Sender: TObject);
begin
  TThread.CreateAnonymousThread(Test).Start;
end;                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:

procedure Test;
var
  TestVar: string;
begin
  TestVar := 'a';
  TThread.Queue(nil, procedure
    begin
      ShowMessage(TestVar); // gibt b aus
    end);
  TestVar := 'b';
end;

procedure TForm259.FormCreate(Sender: TObject);
begin
  TThread.CreateAnonymousThread(Test).Start;
end;                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:

procedure Test;
var
  TestVar: string;
begin
  TestVar := 'a';
  TThread.Queue(nil, procedure
    begin
      ShowMessage(TestVar); // gibt b aus
    end);
   while TThread.CheckTerminated=false do sleep(10);
  TestVar := 'b';
end;                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
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:

type
  TThreadParamMethod<T> = reference to procedure(const AData: T);

  TDataQueueThread = class helper for TThread
  public
    class procedure QueueData<T>(const AData: T; const AProc: TThreadParamMethod<T>);
  end;

// ...

class procedure TDataQueueThread.QueueData<T>(const AData: T; const AProc: TThreadParamMethod<T>);
begin
  TThread.Queue(nil, procedure
    begin
      AProc(AData);
    end);
end;

procedure Test;
var
  TestVar: string;
begin
  TestVar := 'a';
  TThread.Queue(nil, procedure
    begin
      ShowMessage('Queue vorher: ' + TestVar); // gibt Queue vorher: b aus
    end);
  TThread.QueueData<string>(TestVar, procedure(const AData: string)
    begin
      ShowMessage('QueueData vorher: ' + AData); // gibt QueueData vorher: a aus
    end);
  TestVar := 'b';
  TThread.Queue(nil, procedure
    begin
      ShowMessage('Queue nachher: ' + TestVar); // gibt Queue nachher: b aus
    end);
  TThread.QueueData<string>(TestVar, procedure(const AData: string)
    begin
      ShowMessage('QueueData nachher: ' + AData); // gibt QueueData nachher: b aus
    end);
end;

procedure TForm259.FormCreate(Sender: TObject);
begin
  TThread.CreateAnonymousThread(Test).Start;
end;                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
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:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:

unit ufrmMultiThreadedWebspider;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls, Vcl.ExtCtrls, Vcl.StdCtrls,
  uMultiThreadedWebspider, Vcl.Mask, AdvSpin, Vcl.ImgList, SyncObjs, DateUtils;

type
  TfrmMultiThreadedWebspider = class(TForm)
    Panel1: TPanel;
    sbWebSpider: TStatusBar;
    pcWebSpiderResults: TPageControl;
    tsInternalLinks: TTabSheet;
    lvInternalLinks: TListView;
    Panel2: TPanel;
    btnStartStopPause: TButton;
    Label1: TLabel;
    edURL: TComboBox;
    Label4: TLabel;
    seThreads: TAdvSpinEdit;
    Panel3: TPanel;
    cbIgnoreURLType: TCheckBox;
    lblStartTime: TLabel;
    lblStopTime: TLabel;
    lblNeededTime: TLabel;
    TabSheet1: TTabSheet;
    ilStatusIcons: TImageList;
    procedure btnStartStopPauseClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    StartTime         : TDateTime;
    StopTime          : TDateTime;
    { Public-Deklarationen }
    // get next item to analyse
    procedure GetNextAnalyseItem;
    // event handling der Threads
    procedure URLAnalysisBegin();
    procedure URLAnalysisDone(index : integer);
    procedure AddInternalLinkToListView(origurl,origlink,url : string);
  end;

var
  frmMultiThreadedWebspider: TfrmMultiThreadedWebspider;

implementation

{$R *.dfm}

procedure TfrmMultiThreadedWebspider.AddInternalLinkToListView(origurl,
  origlink, url: string);
var
 i : integer;
 TempItem : TListItem;
 TempData : PWebURLDataItem;
 TempParentItem : PWebURLParentDataItem;
begin
 // set tempitem default
 TempItem := nil;
 // check if the item exists already
 for i := 0 to lvInternalLinks.Items.Count -1 do
  begin
   if lvInternalLinks.Items[i].Caption = url then
    begin
     TempItem := lvInternallinks.Items[i];
     break;
    end;
  end;
 // check if the item has to be created
 if TempItem = nil then
  begin
   // url does not exist ... add new item and data structures
   // create tempitem
   TempItem := lvInternalLinks.Items.Add;
   TempItem.Caption := url;
   TempItem.SubItems.Add(origurl);
   TempItem.SubItems.Add(origlink);
   TempItem.StateIndex := 0;
   // create tempdata item
   new(TempData);
   TempData.URLString := url;
   TempData.URLLinkString := origlink;
   TempData.OrigURLString := origurl;
   TempData.URLType := utInternalURL;
   // create list for parent sites
   TempData.ParentSites := TList.Create;
   // add temp data item to temp item
   TempItem.Data := TempData;
   // create tempparenitem
   new(TempParentItem);
   TempParentItem.URLString := url;
   TempParentItem.URLLinkString := origlink;
   TempParentItem.OrigURLString := origurl;
   // add parent item to parent sites list
   TempData.ParentSites.Add(TempParentItem);
  end
 else
  begin
   // url exists ... add parent data structures
   // check if a structure is assigned to the data pointer
   if TempItem.Data <> nil then
    begin
     // check if parent sites list is created
     if PWebURLDataItem(TempItem.Data).ParentSites <> nil then
      begin
       // now add the parent site data structure
       // create tempparenitem
       new(TempParentItem);
       TempParentItem.URLString := url;
       TempParentItem.URLLinkString := origlink;
       TempParentItem.OrigURLString := origurl;
       // add parent item to parent sites list
       PWebURLDataItem(TempItem.Data).ParentSites.Add(TempParentItem);
      end;
    end;
  end;
end;

procedure TfrmMultiThreadedWebspider.btnStartStopPauseClick(Sender: TObject);
var
 TempItem : TListItem;
 i : integer;
 TempData : PWebURLDataItem;
 TempParentItem : PWebURLParentDataItem;
 AnalyseThread : TURLAnalyser;
begin
 // start analysis
 // set tab page
 pcWebSpiderResults.ActivePageIndex := 0;
 // set button
 btnStartStopPause.Enabled := false;
 // set cursor
 Cursor := crHourGlass;
 // get start time
 StartTime := now;
 // set start time label
 lblStartTime.caption := DateTimeToStr(StartTime);
 // clear listview
 lvInternalLinks.items.Clear;
 // add first item to list
 TempItem := lvInternalLinks.Items.Add;
 TempItem.Caption := edURL.Text;
 TempItem.SubItems.Add('');
 TempItem.SubItems.Add('');
 TempItem.StateIndex := 0;
 // create tempdata item
 new(TempData);
 TempData.URLString := edURL.Text;
 TempData.URLLinkString := '';
 TempData.OrigURLString := '';
 TempData.URLType := utInternalURL;
 // create list for parent sites
 TempData.ParentSites := TList.Create;
 // create tempparenitem
 new(TempParentItem);
 TempParentItem.URLString := edURL.Text;
 TempParentItem.URLLinkString := '';
 TempParentItem.OrigURLString := edURL.Text;
 // add parent item to parent sites list
 TempData.ParentSites.Add(TempParentItem);
 // add data to listitem
 TempItem.Data := TempData;
 // set active threads count
 ActiveThreads := 0;
 // increase active threads counter
 inc(ActiveThreads);
 // now create first thread and analyse first item
 AnalyseThread := TURLAnalyser.Create(edURL.Text,edURL.Text,cbIgnoreURLType.Checked,TempItem.Index);
 AnalyseThread.FreeOnTerminate  := true;
 AnalyseThread.URLAnalysisBegin := URLAnalysisBegin;
 AnalyseThread.URLAnalysisDone  := URLAnalysisDone;
 AnalyseThread.AddInternalLink  := AddInternalLinkToListView;
 AnalyseThread.Resume;
 // wait until analysis is finished
 while ((AnalyseThread.Finished = false) or (ActiveThreads > 0)) do
  begin
   Application.ProcessMessages;
  end;
 // get stop time
 StopTime := now;
 // set stop time label
 lblStopTime.caption := DateTimeToStr(StopTime);
 // set needed time label
 lblNeededTime.caption := TimeToStr(StopTime-StartTime) + ' (' + IntToStr(SecondsBetween(StopTime,StartTime)) + ' Seconds)';
 // set cursor
 Cursor := crDefault;
 // set button
 btnStartStopPause.Enabled := true;
 // show message that analysis has been finished
 ShowMessage('Analysis of ' + edURL.Text + ' has been finished!');
end;

procedure TfrmMultiThreadedWebspider.FormCreate(Sender: TObject);
begin
 // set tab page
 pcWebSpiderResults.ActivePageIndex := 0;
 // set labels
 lblStartTime.Caption := '-';
 lblStopTime.Caption := '-';
 lblNeededTime.Caption := '-';
end;

procedure TfrmMultiThreadedWebspider.GetNextAnalyseItem;
var
 i : integer;
 AnalyseThread : TURLAnalyser;
begin
 // check if there are more items to be analysed
 for i := 0 to lvInternalLinks.Items.Count -1 do
  begin
   // check if this item has not been analysed yet
   if PWebURLDataItem(lvInternalLinks.Items[i].Data).Analysed = false then
    begin
     // check if we have the ressources to create another thread
     if ActiveThreads <= seThreads.Value then
      begin
       // increase active threads counter
       inc(ActiveThreads);
       // set analysed flag
       PWebURLDataItem(lvInternalLinks.Items[i].Data).Analysed := true;
       // now create first thread and analyse first item
       AnalyseThread := TURLAnalyser.Create(PWebURLDataItem(lvInternalLinks.Items[0].Data).URLString,PWebURLDataItem(lvInternalLinks.Items[i].Data).URLString,cbIgnoreURLType.Checked,i);
       AnalyseThread.FreeOnTerminate  := true;
       AnalyseThread.URLAnalysisBegin := URLAnalysisBegin;
       AnalyseThread.URLAnalysisDone  := URLAnalysisDone;
       AnalyseThread.AddInternalLink  := AddInternalLinkToListView;
       AnalyseThread.Resume;
      end
     else
      begin
       // maximum threads is reached
       // exit the for loop
       break;
      end;
    end;
  end;
 // check if there are more items to be deep analysed


end;

procedure TfrmMultiThreadedWebspider.URLAnalysisBegin();
begin
 // update label in statusbar
 sbWebSpider.Panels[0].Text := 'Threads: ' + inttostr(ActiveThreads);
 // update label in statusbar
 sbWebSpider.Panels[1].Text := 'ListItems: ' + inttostr(lvInternalLinks.Items.Count);
end;

procedure TfrmMultiThreadedWebspider.URLAnalysisDone(index: integer);
begin
 // set item do analysed
 if index <= lvInternalLinks.items.Count  then
  lvInternalLinks.Items[index].StateIndex := 1;
 // decrease active threads counter
 dec(ActiveThreads);
 // update label in statusbar
 sbWebSpider.Panels[0].Text := 'Threads: ' + inttostr(ActiveThreads);
 // update label in statusbar
 sbWebSpider.Panels[1].Text := 'ListItems: ' + inttostr(lvInternalLinks.Items.Count);
 // get next analyse item and start thread if possible
 GetNextAnalyseItem;
end;

end.                    

1:
2:
3:
4:
5:
6:
7:
8:
9:
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:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:
367:
368:
369:
370:
371:
372:
373:
374:
375:
376:
377:
378:
379:
380:
381:
382:
383:
384:
385:
386:
387:
388:
389:
390:
391:
392:
393:
394:
395:
396:
397:
398:
399:
400:
401:
402:
403:
404:
405:
406:
407:
408:
409:
410:
411:
412:
413:
414:
415:
416:
417:
418:
419:
420:
421:
422:
423:
424:
425:
426:
427:
428:
429:
430:
431:
432:
433:
434:
435:
436:
437:
438:
439:
440:
441:
442:
443:
444:
445:
446:
447:
448:
449:
450:
451:
452:
453:
454:
455:
456:
457:
458:
459:
460:
461:
462:
463:
464:
465:
466:
467:
468:
469:
470:
471:
472:
473:
474:
475:
476:
477:
478:
479:
480:
481:
482:
483:
484:
485:
486:
487:
488:
489:
490:
491:
492:
493:
494:
495:
496:
497:
498:
499:
500:
501:
502:
503:
504:
505:
506:
507:
508:
509:
510:
511:
512:
513:
514:
515:
516:
517:
518:
519:
520:
521:
522:
523:
524:
525:
526:
527:
528:
529:
530:
531:
532:
533:
534:
535:
536:
537:
538:
539:
540:
541:
542:
543:
544:
545:
546:
547:
548:
549:
550:
551:
552:
553:
554:
555:
556:
557:
558:
559:
560:
561:
562:
563:
564:
565:
566:
567:
568:
569:
570:
571:
572:
573:
574:
575:
576:
577:
578:
579:
580:
581:
582:
583:
584:
585:
586:
587:
588:
589:
590:
591:
592:
593:
594:

unit uMultiThreadedWebspider;

interface

uses
  System.Classes, System.SysUtils, Winapi.ActiveX, Winapi.UrlMon, Vcl.Dialogs;

  // routine to download the html source of a given url to a stream
  function UrlDownloadToStream(URL: String; Stream: TStream): Boolean;
  // check if string is utf8
  function CheckUTF8(tempstring : string) : integer;
  // prepare url for analysis
  function PrepareURLforAnalysis(origurl,parsedurlhost,parsedurlprotocol: string): string;

var
 ActiveThreads : integer;

const
 sGeneralLinkTagStart = '<a';
 sGeneralLinkTagEnd = '/a>';
 sGeneralHrefTagStart = 'href="';
 sGeneralHrefTagEnd = '"';
 sGeneralMetaLinkTagStart = '<link ';
 sGeneralMetaLinkTagEnd = '>';

 // url type
 utNone = 0;
 utInternalURL = 1;
 utExternalURL = 2;
 utInternalImageLinkURL = 3;
 utExternalImageLinkURL = 4;
 utInternalFeedLinkURL = 5;
 utFileLinkURL = 6;
 utImageLinkURL = 7;
 utImageURL = 8;
 utNotAnalysedURL = 9;
 utExternalFeedLinkURL = 10;

 // sender mode
 smNone = 0;
 smInternalURL = 1;
 smExternalURL = 2;
 smInternalImageLinkURL = 3;
 smExternalImageLinkURL = 4;
 smInternalFeedLinkURL = 5;
 smFileLinkURL = 6;
 smImageLinkURL = 7;
 smImageURL = 8;
 smNotAnalysedURL = 9;
 smExternalFeedLinkURL = 10;

 // deep analyse mode
 damNone = 0;
 damInternalURL = 1;
 damExternalURL = 2;
 damInternalImageLinkURL = 3;
 damExternalImageLinkURL = 4;
 damInternalFeedLinkURL = 5;
 damFileLinkURL = 6;
 damImageLinkURL = 7;
 damImageURL = 8;
 damNotAnalysedURL = 9;
 damExternalFeedLinkURL = 10;

type
  // EebURLParentDataItem
  TWebURLParentDataItem = packed record
   URLString          : string;      // url
   OrigURLString      : string;      // orig url string
   URLLinkString      : string;      // link wich contains the url
  end;
  PWebURLParentDataItem = ^TWebUrlParentDataItem;

  // WebURLData record
  TWebURLDataItem = packed record
   URLString          : string;      // url
   OrigURLString      : string;      // orig url string
   URLLinkString      : string;      // link wich contains the url
   URLType            : integer;     // url type
   Analysed           : boolean;     // is the url analysed
   DeepAnalysed       : boolean;     // is the url deep analysed
   HTTPStatus         : integer;     // url http status
   PageRank           : integer;     // url pagerank
   InternalLinks      : integer;     // internal links on url
   ExternalLinks      : integer;     // external links on url
   SiteTitle          : string;      // url site title
   METATagKeywords    : string;      // url meta tag keywords
   METATagDescription : string;      // url meta tag description
   SiteFollowTag      : integer;     // site follow tag ( -1 = not set | 0 = nofollow | 1 = follow )
   FileSize           : int64;       // file size if it is a file

   ParentSites        : TList;       // list of paren items and data
  end;
  PWebURLDataItem = ^TWebURLDataItem;

  // url analysis done
  TURLAnalysisBegin = procedure() of object;
  // url analysis done
  TURLAnalysisDone = procedure(index : integer) of object;
  // add internal item to listview
  TAddInternalLink = procedure(origurl,origlink,url : string) of object;

  // URL Analyser Thread
  TURLAnalyser = class(TThread)
  strict private
    FFormHandle         : THandle;
    FRootURL            : string;           // given root url to analyse
    FAnalyseURL         : string;           // url to analyse
    FParsedURLProtocol  : string;           // parsed url protocol
    FParsedURLHost      : string;           // parsed url host
    FIgnoreURLType      : boolean;          // ignore url type flag
    FURLName            : string;           // url without www
    FWWWURLName         : string;           // url with www
    FItemIndex          : integer;          // ListIndex of the corresponding Listview Item

    Forigurlname        : string;
    FStripParams        : boolean;
    FDetectAllImages    : boolean;
    FDetectFeeds        : boolean;
    FSenderMode         : integer;

    // results
    FResultOrigURL      : string;           // original url from the source
    FResultURL          : string;           // result url friendly for the views and further analysis
    FResultOrigLink     : string;           // original link source
    // synchronisation
    FURLAnalysisBegin   : TURLAnalysisBegin;
    FURLAnalysisDone    : TURLAnalysisDone;
    FAddInternalLink    : TAddInternalLink;
    procedure SyncURLAnalysisBegin;
    procedure SyncURLAnalysisDone;
    procedure SyncAddInternalLink;
  protected
    procedure   Execute; override;
  public
    constructor Create(RootURL,AnalyseURL : string;IgnoreURLType : boolean;Index : integer);
    destructor  Destroy; override;
    // properties
    property    URLAnalysisBegin  : TURLAnalysisBegin read FURLAnalysisBegin write FURLAnalysisBegin;
    property    URLAnalysisDone   : TURLAnalysisDone  read FURLAnalysisDone  write FURLAnalysisDone;
    property    AddInternalLink   : TAddInternalLink  read FAddInternalLink  write FAddInternalLink;
  end;

implementation

// #############################################################################

function UrlDownloadToStream(URL: String; Stream: TStream): Boolean;
var  ppStream:   IStream;
     statstg:    TStatStg;
     lpBuffer:   Pointer;
     dwRead:     Integer;
begin
  // Set default result
  result:=False;

  // Make sure stream is assigned
  if Assigned(Stream) then
  begin
     // Open blocking stream
     if (URLOpenBlockingStream(nil, PChar(URL), IStream(ppStream), 0, nil) = S_OK) then
     begin
        // Resource protection
        try
           // Get the stat from the IStream interface
           if (ppStream.Stat(statstg, STATFLAG_NONAME) = S_OK) then
           begin
              // Make sure size is greater than zero
              if (statstg.cbSize > 0) then
              begin
                 // Allocate buffer for the read
                 lpBuffer:=AllocMem(statstg.cbSize);
                 // Resource protection
                 try
                    // Read from the stream
                    if (ppStream.Read(lpBuffer, statstg.cbSize, @dwRead) = S_OK) then
                    begin
                       // Write to delphi stream
                       Stream.Write(lpBuffer^, dwRead);
                       // Resource protection
                       try
                          // Rewind
                          Stream.Seek(-dwRead, soFromCurrent);
                       finally
                          // Success
                          result:=True;
                       end;
                    end;
                 finally
                    // Free the buffer
                    FreeMem(lpBuffer);
                 end;
              end;
           end;
        finally
           // Release the IStream interface
           ppStream:=nil;
        end;
     end;
  end;
end;

// #############################################################################

function CheckUTF8(tempstring : string) : integer;
begin
 result := -1;

 if POS('ä',tempstring,1) <> 0 then result := 1;
 if POS('ü',tempstring,1) <> 0 then result := 1;
 if POS('ö',tempstring,1) <> 0 then result := 1;
 if POS('Ø',tempstring,1) <> 0 then result := 1;
 exit;
 if POS('&',tempstring,1) <> 0 then result := 2;
 if POS('ä',tempstring,1) <> 0 then result := 2;
 if POS('Ä',tempstring,1) <> 0 then result := 2;
 if POS('ü',tempstring,1) <> 0 then result := 2;
 if POS('Ü',tempstring,1) <> 0 then result := 2;
 if POS('ö',tempstring,1) <> 0 then result := 2;
 if POS('Ö',tempstring,1) <> 0 then result := 2;

end;

// #############################################################################

function PrepareURLforAnalysis(origurl,parsedurlhost,parsedurlprotocol: string): string;
var
 tempurlstring : string;
begin
 // check for bad urls
 if origurl = '' then exit;
 // prepare url to make it analysable
 tempurlstring := origurl;
 if tempurlstring[1] = '.' then delete(tempurlstring,1,1);
 tempurlstring := StringReplace(tempurlstring,'/http','http',[rfReplaceAll]);
 tempurlstring := StringReplace(tempurlstring,'/https','https',[rfReplaceAll]);
 tempurlstring := StringReplace(tempurlstring,'http//','http://',[rfReplaceAll]);
 tempurlstring := StringReplace(tempurlstring,'https//','https://',[rfReplaceAll]);
 tempurlstring := StringReplace(tempurlstring,'http:/http','http',[rfReplaceAll]);
 // now prepare the url for the further use in the routine
 if ((POS(UpperCase(ParsedURLHost),UpperCase(tempurlstring)) = 0) and
     (POS(UpperCase('http://'),UpperCase(tempurlstring)) = 0) and
     (POS(UpperCase('https://'),UpperCase(tempurlstring)) = 0)) then
  begin
   if ((tempurlstring[1] <> '/') and (tempurlstring[1] <> '?')) then
    begin
     if POS(UpperCase(ParsedURLProtocol + '://'),UpperCase(tempurlstring),1) = 0 then
      tempurlstring := '/' + tempurlstring;
    end;
   if POS(UpperCase('www.'),UpperCase(origurl),1) <> 0 then
    begin
     if POS(UpperCase(ParsedURLProtocol + '://'),UpperCase(tempurlstring),1) = 0 then
      tempurlstring := ParsedURLProtocol + '://www.' + ParsedURLHost + tempurlstring
    end
   else
    begin
     if POS(UpperCase(ParsedURLProtocol + '://'),UpperCase(tempurlstring),1) = 0 then
      tempurlstring := ParsedURLProtocol + '://' + ParsedURLHost + tempurlstring
    end;
  end;
 tempurlstring := StringReplace(tempurlstring,'www.www','www',[rfReplaceAll]);
 result := tempurlstring;
end;

// #############################################################################

function parseProtocol(url: string): string;
var
  i: integer;
begin
  { Parse out the protocol part of url }

  { Locate protocol seperator }
  i := pos('://', Url);
  if i <> 0 then begin
    { The protocol is everything until the seperator }
    Result := Copy(url, 1, i - 1);
  end else begin
    { If no protocol is found, set the default protocol }
    result := 'http';
  end;
end;

// #############################################################################

function parseHost(url: string): string;
var
  i, pathSep, portSep: integer;
  tmpstr: string;
begin
  { Parse out the host part from url }
  tmpstr := url;

  { Locate the protocol seperator }
  i := pos('://', tmpstr);
  if i <> 0 then begin
    Inc(i, 2);
  end;
  Delete(tmpstr, 1, i);

  { Locate the path seperator }
  pathSep := Pos('/', tmpstr);
  if pathSep <> 0 then begin
    { Delete everything beyond path seperator }
    Delete(tmpstr, pathSep, Length(tmpstr));
  end;

  { Locate port number seperator }
  portSep := Pos(':', tmpstr);
  if portSep <> 0 then begin
    { If port number found, then delete it }
    Delete(tmpstr, portSep, Length(tmpstr));
  end;

  { If we find parameter seperator know, the url is invalid, but still let's
    clear it out if it's found }
  i := pos('?', tmpstr);
  if i <> 0 then begin
    Delete(tmpstr, i, Length(tmpstr));
  end;

  { Same goes for the bookmark seperator }
  i := pos('#', tmpstr);
  if i <> 0 then begin
    Delete(tmpstr, i, Length(tmpstr));
  end;

  { Now we should only hold the host part }
  Result := tmpstr;
end;

// #############################################################################

function ExtractURLFileName(URL: string): string;
var
 i: Integer;
 temphost : string;
 temppos : integer;
begin
 Result := '';
 temphost := '';
 // check if there is a host and then remove it from the string
 temphost := parseHost(Url);
 if temphost <> '' then
  temppos := POS(Uppercase(temphost),UpperCase(Url),1);
  if temppos <> 0 then
   begin
    Url := COPY(Url,temppos + Length(temphost),Length(Url)-Length(temphost)+1);
   end;
 if POS(Uppercase('http://'),UpperCase(Url),1) = 1 then
  Url := COPY(Url,Length('http://'),Length(Url)-Length('http://')+1);
 if POS(Uppercase('https://'),UpperCase(Url),1) = 1 then
  Url := COPY(Url,Length('https://'),Length(Url)-Length('https://')+1);
 if POS(Uppercase('http://www.'),UpperCase(Url),1) = 1 then
  Url := COPY(Url,Length('http://www.'),Length(Url)-Length('http://www.')+1);
 if POS(Uppercase('https://www.'),UpperCase(Url),1) = 1 then
  Url := COPY(Url,Length('https://www.'),Length(Url)-Length('https://www.')+1);
 i := LastDelimiter('/', Url);
 Result := Copy(Url, i + 1, Length(Url) - (i));
end;

// #############################################################################

{ TURLAnalyser }

constructor TURLAnalyser.Create(RootURL,AnalyseURL: string;IgnoreURLType : boolean;index : integer);
begin
  inherited Create(true);
 // url anlysis starts
 Synchronize(SyncURLAnalysisBegin);
 // variables
 FItemIndex := Index;
 FRootURL := RootURL;
 FAnalyseURL := AnalyseURL;
 FIgnoreURLType := IgnoreURLType;
 FParsedURLProtocol := parseProtocol(RootURL);
 FParsedURLHost     := parseHost(RootURL);
 Furlname           := FParsedURLProtocol + '://' + FParsedURLHost;
 Fwwwurlname        := FParsedURLProtocol + '://www.' + FParsedURLHost;
end;

destructor TURLAnalyser.Destroy;
begin
 // url anlysis completed
 Synchronize(SyncURLAnalysisDone);
  inherited;
end;

procedure TURLAnalyser.Execute;
var
 URLSource : TStringStream;
 urlstring : string;
 tempencoding : TEncoding;
 tempSiteTitleTagString : string;
 tempstring,tempstatuscode,completerobotstagstring,completelinkstring,completeurlstring,completeoriginalurlstring,temppagerank : string;
 sitetitletagstartpos,titletagpos,URLIndex,templistindex,i,robotstagstartpos,robotstagendpos,hrefstartpos,hrefendpos,linkstartpos,linkendpos,imagetagpos : integer;
 urlglobalfollowtag,internallinks,externallinks : integer;
 tempkeywords, tempdescription, temporigurl : string;
 TempList : TList;
begin
 try
 // download the source from the url
 if FAnalyseURL <> '' then
  begin
   URLSource := TStringStream.Create;
   //if UrlDownloadToStream(UmlauteWeg(FAnalyseURL),URLSource) = true then
   if UrlDownloadToStream(FAnalyseURL,URLSource) = true then
    begin
     // complete website source downloaded successfully
     case CheckUTF8(URLSource.DataString) of
      -1 : urlstring := URLSource.DataString;
       1 : urlstring := Utf8ToString(URLSource.DataString);
       2 : urlstring := URLSource.DataString;
     end;
     hrefstartpos := 1;
     repeat
      // get href tag
      hrefstartpos := POS(UpperCase(sGeneralHrefTagStart),UpperCase(urlstring),hrefstartpos);
      if hrefstartpos <> 0 then
       begin
        // href tag start found
        hrefendpos := POS(UpperCase(sGeneralhreftagend),urlstring,hrefstartpos+Length(sGeneralHrefTagStart));
        if hrefendpos <> 0 then
         begin
          // href end found
          // get complete original urlstring
          completeoriginalurlstring := COPY(urlstring,hrefstartpos+Length(sGeneralHrefTagStart),hrefendpos-hrefstartpos-Length(sGeneralHrefTagEnd)-Length(sGeneralHrefTagStart)+1);
          // copy the result to the result variable
          FResultOrigURL := completeoriginalurlstring;
          // prepare urlstring for list and analysis
          completeurlstring := PrepareURLforAnalysis(completeoriginalurlstring,FParsedURLHost,FParsedURLProtocol);
          // copy the result to the result variable
          FResultURL := completeurlstring;
          // now get complete linkstring
          for i := hrefstartpos downto 0 do
           begin
            // look for <a
            if ((UpperCase(urlstring[i]) = UpperCase('<')) and
                (UpperCase(urlstring[i+1]) = UpperCase('a')) and
                (UpperCase(urlstring[i+2]) = UpperCase(' '))) then
             begin
              // found <a
              // get current link start position into variable
              linkstartpos := i;
              // now search for link endpos
              linkendpos := POS(UpperCase(sGeneralLinkTagEnd),UpperCase(urlstring),linkstartpos+Length(sGeneralLinkTagEnd));
              if linkendpos <> 0 then
               begin
                // found /a>
                // get complete linkstring
                completelinkstring := COPY(urlstring,linkstartpos,linkendpos-linkstartpos+Length(sGeneralLinkTagEnd));
                // copy the result to the result variable
                FResultOrigLink := completelinkstring;
                // exit the for loop
                break;
               end
              else
               begin
                // /a> not found
               end;
             end
            else
             begin
              // <a not found
             end;
            // look for <link
            if ((UpperCase(urlstring[i]) = UpperCase('<')) and
                (UpperCase(urlstring[i+1]) = UpperCase('l')) and
                (UpperCase(urlstring[i+2]) = UpperCase('i')) and
                (UpperCase(urlstring[i+3]) = UpperCase('n')) and
                (UpperCase(urlstring[i+4]) = UpperCase('k')) and
                (UpperCase(urlstring[i+5]) = UpperCase(' '))) then
             begin
              // found <link
              // get current link start position into variable
              linkstartpos := i;
              // now search for link endpos
              linkendpos := POS(UpperCase(sGeneralMetaLinkTagEnd),UpperCase(urlstring),linkstartpos+length(sGeneralMetaLinkTagStart));
              if linkendpos <> 0 then
               begin
                // found >
                // get complete linkstring
                completelinkstring := COPY(urlstring,linkstartpos,linkendpos-linkstartpos+Length(sGeneralLinkTagEnd)-1);
                // copy the result to the result variable
                FResultOrigLink := completelinkstring;
                // exit the for loop
                break;
               end
              else
               begin
                // > not found
               end;
             end
            else
             begin
              // <link not found
             end;
           end;
          // all source strings have been fetched
          // now check if it is internal or external
          if  ((POS(UpperCase(FRootURL),UpperCase(completeurlstring),1) = 1) and
               (FIgnoreURLType = false)) or
             (((POS(UpperCase(Furlname),UpperCase(completeurlstring),1) = 1) or
               (POS(UpperCase(Fwwwurlname),UpperCase(completeurlstring),1) = 1)) and
               (FIgnoreURLType = true)) then
           begin
            // the lnk is internal
            // extract url file if we have one
            tempstring := ExtractURLFileName(completeurlstring);
            // check if it is a file
            if ((tempstring <> '') and                     // external domain
                (tempstring <> ' ') and                    // external domain
                (tempstring <> '/') and                    // external domain
                (POS('?',tempstring,1) = 0) and            // parameters point to a link
                (POS('%',tempstring,1) = 0) and            // parameters point to a link
                (POS('&',tempstring,1) = 0) and            // parameters point to a link
                (POS(':',tempstring,1) = 0) and            // parameters point to a link
                (POS('#',tempstring,1) = 0) and            // parameters point to a link
                (POS('.php',tempstring,1) = 0) and         // .php point to a link
                (POS('.htm',tempstring,1) = 0) and         // .htm point to a link
                (POS('.',tempstring,1) <> 0)) or           // . must exist for a file
                (POS('.css',tempstring,1) <> 0) or
                (POS('.js',tempstring,1) <> 0) then
             begin
              // it is a internal file

             end
            else
             begin
              // it is a link
              Synchronize(SyncAddInternalLink);

             end;
           end
          else
           begin
            // the link is external


           end;
          // adjust search position of search
          if linkendpos > hrefendpos then
           hrefstartpos := linkendpos
          else
           hrefstartpos := hrefendpos+Length(sGeneralLinkTagEnd);
         end
        else
         begin
          // href end not found
          // set new search start location
          hrefstartpos := hrefstartpos + length(sGeneralHrefTagStart) + length(sGeneralHrefTagEnd);
         end;
       end
      else
       begin
        // href start not found
        // so there are no more links in the source
       end;
     until hrefstartpos = 0;
    end
   else
    begin
     // URL source download failed
     // so we cannot analyse this page source
    end;
  end;
 except on E: Exception do
  begin
   // error handling
  end;
 end;
 // free stream if needed
 if URLSource <> nil then freeandnil(URLSource);
end;

procedure TURLAnalyser.SyncAddInternalLink;
begin
 if Assigned(AddInternalLink) then
  FAddInternalLink(FResultOrigURL,FResultOrigLink,FResultURL);
end;

procedure TURLAnalyser.SyncURLAnalysisBegin;
begin
 if Assigned(URLAnalysisBegin) then
  FURLAnalysisBegin();
end;

procedure TURLAnalyser.SyncURLAnalysisDone;
begin
 if Assigned(URLAnalysisDone) then
  FURLAnalysisDone(FItemIndex);
end;

end.