PhLdr104a.bbc

10 REM >PhoneLdr v1.04

20 REM Internet Telephone Lookup for EARS Data

30 REM (C) Jon Ripley 2006

40 REM v1.00 29-04-2006 JJR Original version

50 REM v1.01 30-04-2006 JGH: Added TPS format output to zip file

60 REM v1.02 20-06-2006 JGH: Uses GetOpenFileName dialogue

70 REM v1.03 29-08-2006 JGH: URL configurable via ini file

80 REM v1.04 02-03-2007 JGH: Opens output file only when needed, checks for overuse of website

90 REM Tidies up output file if aborted

100 :

110 ON ERROR REPORT:PROCClose_All:PRINTLEFT$(" at "+TIME$,ERR<>17):PROCQuit

120 :

130 in$="":out$="" :REM Clear filenames

140 eol$=CHR$13+CHR$10 :REM Win/DOS end of line sequence

150 delay%=150 :REM Default delay in cs

160 year$=MID$(TIME$,12,4) :REM Register year

170 warn%=0 :REM No warnings yet

180 DIM info$(12), of% 75, fn% 255, zp% 5, mem% 255

190

200 A$=@cmd$:progpath$=@dir$:inpath$="":outpath$=""

210 IFFNcl("-?",0):PRINT"Syntax: PhoneLdr <infile> [<outfile>] [-ini <inifile>] [-delay <cs>] [-text]":PROCQuit:END

220 :

230 REM Read command line: Syntax: <infile> [<outfile>] [-ini <inifile>] [-delay delay] [-text] [-debug]

240 ini$=FNcl("-i",1)

250 del$=FNcl("-d",1)

260 zip%=NOTFNcl("-t",0)

270 dbg%=FNcl("-debug",0)

280 in$ =FNcl("",0)

290 out$=FNcl("",0)

300 :

310 IFini$="":ini$=progpath$+"PhoneLdr.ini"

320 in%=0:IFini$<>"":in%=OPENIN(ini$)

330 IFin%=0:in%=OPENIN(inpath$+"PhoneLdr.ini"):IFin%=0:in%=OPENIN(progpath$+"PhoneLdr.ini")

340 urlbase$="":delay$=""

350 IF in% THEN

360 REPEAT

370 A$=GET$#in%

380 IFLEFT$(FNuc(A$),4)="URL=":urlbase$=MID$(A$,5)

390 IFLEFT$(FNuc(A$),6)="DELAY=":delay$=MID$(A$,7)

400 UNTILEOF#in%:CLOSE#in%:in%=0

410 ENDIF

420 IFdbg%:PRINTurlbase$

430 IFdel$="":del$=delay$

440 IFdel$<>"":delay%=VALdel$

450 :

460 A%=INSTR(urlbase$,"?"):urlLOC$=MID$(urlbase$,A%+1):urlbase$=LEFT$(urlbase$,A%)

470 IFA%=0:PROCbadurl:PROCQuit

480 REM Isolate URL base:

490 REM urlbase$=http://www.thephonebook.bt.com/publisha.content/en/find/residential/residential_numbers.publisha

500 REM urlLOC$ =?Surname=Harton&Initial=J&Street=70+Camm+Street&Location=Sheffield%7B+-+Yorkshire%7D

510 :

520 A%=INSTR(urlLOC$,"&LOC="):IFA%=0:A%=INSTR(urlLOC$,"&Location="):B%=INSTR(urlLOC$,"&Town="):IF B%<A%:A%=B%

530 urlLOC$=MID$(urlLOC$,A%)

540 IFA%=0:PROCbadurl:PROCQuit

550 REM Find '&Location=.....' or '&Town-....'

560 REM urlbase$=http://www.thephonebook.bt.com/publisha.content/en/find/residential/residential_numbers.publisha

570 REM urlLOC$ =&Location=Sheffield%7B+-+Yorkshire%7D

580 :

590 IFdbg%:PRINTurlbase$'urlLOC$

600 :

610 IFin$="" THEN

620 ff$ = "All files"+CHR$0+"*.*"+CHR$0+CHR$0

630 !of% = 76:of%!4 = @hwnd%:of%!12 = !^ff$

640 of%!28 = fn%:of%!32 = 256:of%!52 = 6

650 SYS "GetOpenFileName", of% TO result%:IF result%:in$=$$fn%

660 ENDIF

670 IF in$="":QUIT

680 inpath$=FNpath(in$):in$=FNleaf(in$)

690 IF out$="":outpath$=inpath$:out$="TPSClean.out":IF zip%:out$="TPSClean.zip"

700 in$=FNfullpath(inpath$,in$)

710 out$=FNfullpath(outpath$,out$)

720 :

730 in%=OPENINin$:IF in%=0 PRINT "File not found.":PROCQuit

740 ON ERROR REPORT:PROCClose_All:PROCtidy:PRINTLEFT$(" at "+TIME$,ERR<>17):PROCQuit

750 PROCheader

760 PROClookup

770 PROCfooter

780 CLOSE#in%:in%=0

790 IF warn%:PROCQuit ELSE QUIT

800 :

810 DEFPROCheader

820 out%=OPENOUTout$:IF out%=0 PRINT "Cannot create output file.":CLOSE#in%:in%=0:PROCQuit

830 crc%=-1:tidycrc%=crc%:tidyptr%=0

840 IF zip% THEN

850 name$="TPSClean.out"

860 mtime%=&001E15 :REM 21:30:00

870 mdate%=&C735 :REM 21/7/2009

880 PROCwr32(out%,&04034B50)

890 PROCwr16(out%,&000A)

900 PROCwr16(out%,&0000)

910 PROCwr16(out%,&0000)

920 PROCwr16(out%,FNztime(mtime%))

930 PROCwr16(out%,FNzdate(mdate%))

940 PROCwr32(out%,crc%) :REM CRC, fill in later

950 PROCwr32(out%,&00000000):REM Filesize, fill in later

960 PROCwr32(out%,&00000000):REM Filesize, fill in later

970 PROCwr16(out%,LEN name$)

980 PROCwr16(out%,&0000)

990 FORx%=1TOLEN name$:BPUT#out%,ASCMID$(name$,x%,1):NEXT

1000 ptr0%=PTR#out%

1010 ENDIF

1020 REM Output TPS file header

1030 PROCwr("EARS V8 TPS update IMPORT file - for register year of "+year$)

1040 PROCwr("- EXPIRES :31/12/"+MID$(year$,3)+eol$)

1050 OSCLI"ESC OFF":tidyptr%=PTR#out%:tidycrc%=crc%:OSCLI"ESC ON"

1060 CLOSE#out%:out%=0

1070 ENDPROC

1080 :

1090 DEFPROClookup

1100 REM Code by Jon Ripley

1110 REM ------------------

1120 SYS "LoadLibrary", "URLMON.DLL" TO urlmon%

1130 SYS "GetProcAddress", urlmon%, "URLDownloadToFileA" TO urld%

1140 a$=GET$#in%:REM Read header

1150 WHILE NOT EOF#in%

1160 a$=GET$#in%

1170 IF a$<>"" THEN

1180 FOR i%=1 TO 12:info$(i%)=FNRdTSF(a$,i%):NEXT i%

1190 PRINTinfo$(3);" ";info$(4);", ";info$(5);LEFT$(" ",info$(6)<>"");info$(6);" ";info$(7);LEFT$(", ",info$(8)<>"");info$(8);

1200 surname$=info$(4)

1210 initial$=LEFT$(info$(3),1)

1220 street$=FNs(info$(5)+" "+info$(7))

1230 REPEATA%=INSTR(street$," "):IFA%:street$=LEFT$(street$,A%-1)+"+"+MID$(street$,A%+1)

1240 UNTILA%=0

1250 url$=urlbase$+"Surname="+surname$+"&Initial="+initial$+"&Street="+street$+urlLOC$

1260 IFdbg%:PRINT'url$

1270 SYS urld%, 0, url$, "out.html", 0 ,0

1280 IFdbg%:PRINT"Page fetched...";:A%=GET:PRINT

1290 :

1300 REM Extract information from file and write to data file

1310 in2%=OPENIN"out.html"

1320 info$(0)="":REM Blank out field for incoming phone number

1330 WHILE (NOT EOF#in2%) AND (info$(0)="")

1340 a$=GET$#in2%:tmp%=BGET#in2%

1350 A%=INSTR(a$,"high usage"):IF A%=0:A%=INSTR(a$,"protect"):IF A%=0:A%=INSTR(a$,"automated")

1360 IF A%:PRINT''"Phonebook site timed out due to high usage - come back to finish later":warn%+=1:ENDPROC

1370 REM Look for <div><span class="phone">Tel: (0114) 281 8708</span>

1380 A%=INSTR(a$,"class=""phone""")

1390 IF A% THEN

1400 a$=MID$(a$,A%+14)

1410 a$=FNs(LEFT$(a$,INSTR(a$+"<","<")-1))

1420 A%=1:REPEATIFINSTR(" 0123456789",MID$(a$,A%,1))=0:a$=LEFT$(a$,A%-1)+MID$(a$,A%+1):A%=A%-1

1430 A%=A%+1:UNTILA%>=LENa$

1440 info$(0)=FNs(a$)

1450 ENDIF

1460 ENDWHILE

1470 CLOSE#in2%:in2%=0

1480 :

1490 PRINT" ";info$(0);

1500 IF info$(0)<>"":IF info$(0)=info$(11):PRINT" - same";:info$(0)="":REM Don't overwrite same numbers

1510 IF info$(0)<>"" THEN

1520 out%=OPENUPout$:PTR#out%=EXT#out%

1530 BPUT#out%,"22|"+info$(1)+"|"+info$(2)+"|"+info$(0)+eol$;

1540 OSCLI"ESC OFF":tidyptr%=PTR#out%:tidycrc%=crc%:OSCLI"ESC ON"

1550 CLOSE#out%:out%=0

1560 ENDIF

1570 PRINT

1580 WAIT delay%

1590 ENDIF

1600 ENDWHILE

1610 crc%=FNrev32(crc%)EOR-1

1620 REM --------------

1630 ENDPROC

1640 :

1650 DEFPROCfooter

1660 IF zip% THEN

1670 out%=OPENUPout$

1680 filesize%=EXT#out%-ptr0%

1690 PTR#out%=14

1700 PROCwr32(out%,crc%)

1710 PROCwr32(out%,filesize%)

1720 PROCwr32(out%,filesize%)

1730 :

1740 REM Zip catalogue

1750 PTR#out%=EXT#out%

1760 ptr1%=PTR#out%

1770 PROCwr32(out%,&02014B50)

1780 PROCwr16(out%,&0014)

1790 PROCwr16(out%,&000A)

1800 PROCwr16(out%,&0000)

1810 PROCwr16(out%,&0000)

1820 PROCwr16(out%,FNztime(mtime%))

1830 PROCwr16(out%,FNzdate(mdate%))

1840 PROCwr32(out%,crc%)

1850 PROCwr32(out%,filesize%)

1860 PROCwr32(out%,filesize%)

1870 PROCwr16(out%,LEN name$)

1880 PROCwr16(out%,&0000)

1890 PROCwr16(out%,&0000)

1900 PROCwr16(out%,&0000)

1910 PROCwr16(out%,&0001)

1920 PROCwr32(out%,&0020)

1930 PROCwr32(out%,&00000000)

1940 FORx%=1TOLEN name$:BPUT#out%,ASCMID$(name$,x%,1):NEXT

1950 ptr2%=PTR#out%

1960 :

1970 REM Zip EOF

1980 PROCwr32(out%,&06054B50)

1990 PROCwr16(out%,0)

2000 PROCwr16(out%,0)

2010 PROCwr16(out%,1)

2020 PROCwr16(out%,1)

2030 PROCwr32(out%,ptr2%-ptr1%)

2040 PROCwr32(out%,ptr1%)

2050 PROCwr16(out%,0)

2060 CLOSE#out%:out%=0

2070 ENDIF

2080 ENDPROC

2090 :

2100 DEFPROCtidy:IFtidyptr%=0:ENDPROC

ENDPROC

2110 OSCLI"ESC OFF"

2120 out%=OPENUPout$:EXT#out%=tidyptr%:CLOSE#out%:out%=0

2130 crc%=tidycrc%:tidycrc%=0

2140 OSCLI"ESC ON"

2150 PROCfooter

2160 ENDPROC

2170 :

2180 :

2190 DEFPROCwr(A$):IFA$="":ENDPROC

2200 BPUT#out%,A$;

2210 $mem%=A$:sz%=LENA$:PROCCalcCRC

2220 ENDPROC

2230 :

2240 DEFPROCCalcCRC

2250 S%=crc%:FORW%=0TOsz%-1:A%=FNrev8(mem%?W%)*256*256*128:A%=A%<<1:S%=S%EORA%

2260 FORZ%=1TO8:T%=(S%AND&80000000):S%=S%<<1:IFT%:S%=S%EOR&04C11DB7

2270 NEXT:NEXT:crc%=S%:ENDPROC

2280 DEFFNrev32(A%):B%=A%:A%=0:FORz%=1TO32:A%=A%+A%:A%=A%OR(B%AND1):B%=((B%DIV2)AND&7FFFFFFF)-((B%AND1)AND(B%<0)):NEXT:=A%

2290 DEFFNrev8(A%):B%=A%:A%=0:FORz%=1TO8:A%=A%+A%:A%=A%OR(B%AND1):B%=B%DIV2:NEXT:=A%

2300 :

2310 DEFPROCClose_All

2320 in% =in% :IFin% :A%=in% :in% =0:CLOSE#A%

2330 in2%=in2%:IFin2%:A%=in2%:in2%=0:CLOSE#A%

2340 out%=out%:IFout%:A%=out%:out%=0:CLOSE#A%

2350 ENDPROC

2360 :

2370 DEFPROCQuit

2380 PRINT'"Press SPACE or click mouse to quit";:REPEATUNTILINKEY-10 OR INKEY-11 OR INKEY-12 OR INKEY(1)<>-1:QUIT

2390 ENDPROC

2400 :

2410 DEFFNRdTSF(in$,f%):IF f%=0 :=""

2420 LOCAL i%:in$=in$+STRING$(f%,":")

2430 IF f%>1 FOR i%=1 TO f%-1:in$=MID$(in$,INSTR(in$,":")+1):NEXT

2440 in$=LEFT$(in$,INSTR(in$,":")-1):=in$

2450 :

2460 DEFFNuc(A$):IFA$="":=""

2470 FOR A%=1 TO LEN A$:IFMID$(A$,A%,1)>"_":A$=LEFT$(A$,A%-1)+CHR$(ASCMID$(A$,A%,1)AND&DF)+MID$(A$,A%+1)

2480 NEXT:=A$

2490 :

2500 DEFFNztime(A%):=(A%AND&1F)*&800+(A%AND&3F00)DIV8+(A%AND&3F0000)DIV&10000

2510 DEFFNzdate(A%):=(A%AND31)+(A%AND&F00)DIV8+((A%AND&F000)DIV8+(A%AND&E0)*256)+&200

2520 :

2530 DEFFNfullpath(p$,f$):IFINSTR(f$,":") OR INSTR(f$,"\\"):=f$

2540 IF RIGHT$(p$,1)<>"\":p$=p$+"\"

2550 =p$+f$

2560 DEFFNpath(A$):IFINSTR(A$,"\")=0:=A$

2570 A%=0:REPEATB%=A%:A%=INSTR(A$,"\",A%+1):UNTILA%=0:=LEFT$(A$,B%)

2580 DEFFNleaf(A$):IFINSTR(A$,"\")=0:=A$

2590 A%=0:REPEATB%=A%:A%=INSTR(A$,"\",A%+1):UNTILA%=0:=MID$(A$,B%+1)

2600 :

2610 DEFPROCwr16(O%,A%):!zp%=A%:FORA%=0TO1:BPUT#O%,zp%?A%:NEXT:ENDPROC

2620 DEFPROCwr32(O%,A%):!zp%=A%:FORA%=0TO3:BPUT#O%,zp%?A%:NEXT:ENDPROC

2630 :

2640 REM > BLib.CmdLine 1.10 27Jul2009

2650 REM v1.10 Parses "quoted" options

2660 :

2670 REM Command Line Parsing

2680 REM ~~~~~~~~~~~~~~~~~~~~

2690 :

2700 REM FNcl() - parse command line for switches, options and parameters

2710 REM ----------------------------------------------------------------

2720 REM FNcl("",0) - return next parameter

2730 REM FNcl(switch$,0) - return TRUE/FALSE if switch$ present

2740 REM FNcl(option$,1) - return option string if present or ""

2750 :

2760 DEFFNcl(l$,n%):IFl$="":A$=FNs(A$):IFASCA$=34:A%=INSTR(A$+""" ",""" ",2):l$=MID$(A$,2,A%-3):A$=FNs(MID$(A$,A%+1)):=l$

2770 IFl$="":A%=INSTR(A$+" "," "):l$=LEFT$(A$,A%-1):A$=FNs(MID$(A$,A%+1)):=l$

2780 IFn%=0:IFl$<>"":A%=INSTR(A$,l$):IFA%:A$=FNs(LEFT$(A$,A%-1)+MID$(A$,INSTR(A$," ",A%)+1)):=TRUE

2790 IFn%=0:IFl$<>"":=FALSE

2800 A%=INSTR(LEFT$(" ",ASCl$=32)+A$,l$):IFA%=0:=""

2810 A$=LEFT$(A$,A%-1)+FNs(MID$(A$,INSTR(A$," ",A%)+1))

2820 IFASCl$=32:l$=MID$(A$,A%):A$=LEFT$(A$,A%-1):=MID$(l$,1-(ASCl$=34),LENl$+2*(ASCl$=34))

2830 IFASCMID$(A$,A%,1)<>34:l$=MID$(A$,A%,INSTR(A$+" "," ",A%)-A%):A$=LEFT$(A$,A%-1)+MID$(A$,A%+LENl$+1):=l$

2840 l$=MID$(A$,A%+1,INSTR(A$+""" ",""" ",A%+1)-A%-1):A$=LEFT$(A$,A%-1)+MID$(A$,A%+LENl$+3):=l$

2850 DEFFNs(A$):IFLEFT$(A$,1)=" ":REPEATA$=MID$(A$,2):UNTILLEFT$(A$,1)<>" "

2860 IFRIGHT$(A$,1)=" ":REPEATA$=LEFT$(A$,LENA$-1):UNTILRIGHT$(A$,1)<>" "

2870 =A$