{$a-}
{$f+}
program agenda;   { }
{$define sorts}
{define mult_mod}
{define cus_stampe}
{define zap}
{define no_ord_file} {dice di compilare le procedure che controllano l'ordine dell'archivio}
{define shortname}
{define cus_concetrate}
{define cus_input}
{define auto_input}
{define cus_output}
{$define sort}
{define addata}
{define strc}  {dice al compilatore di compilare le routine per le strc}
{$define too5g2} {dice al compilatore di non includere le routine perchŠ
                    sono gi… comprese nella unit}
{define pr_ix} {dice al compilatore di compilare la parte riguardante il pr_ix
 perchŠ siamo in resenza di record con chiave  di tipo array}
{define epson}  {dice al compilatore di compilare le routine per la
                 gestione stampante}
{$define stampe} {dice al compilatore se va' compilata la parte riguardante la
                     stampa su carta dei record o no (comprendo quindi .l10 o no)}
uses prgidu,dos,crt,recun,strdef,too5b,too5s {$ifdef too5g2} ,too5g2 {$endif}
			 ,conf2
			 {$ifdef epson},epson{$endif}
			 {$ifndef epson} ,smepson{$endif}
			 ,lptlas2 ,printer ,business
			 {$ifdef sorts} ,sorts {$endif}
			 {$ifndef cus_stampe} ,procprun {$endif};

const

{U+}

{$ifndef cus_stampe}
      maxarg=14;
      maxvar=12;
{$endif}

TYPE
   st1=string[1];
{$ifndef too5g2}
  charset=set of char; {serve in too4proc}
{$endif}

{$ifndef cus_stampe}
  arg_st=array[1..maxarg]of str120;{array per le stampe short}
  arg_n=array[1..maxarg]of integer;{come sopra}
{$endif}


{$ifdef strc}
    strc=string[stlen];
{$endif}

var

    speed,dom,ff:boolean;
    co:integer;{code per input name;pu• essere usato da tutti}
    dataem,localita:string;
    day,month,year,dweek:word;
    config:text;
    baso:file of fatt;
    {tabella tipo argomento:
                                         se arg_v[n] e' | allora arg[n] e'
                                         --------------------------------
                                             0            tipo generico (comando o nome campo)
                                             1            stringa da stampare   }
{$ifdef addata}
     ni:string;{nuova istruzione serve in out da un elaborazione per creare un processo secondo}
{$endif}

{$ifndef too5g2}

{$i too5set}

{$endif}



{$i  \tp\stand\comp1}

{$i  \tp\stand\proc0}

{$i  \tp\stand\proc1}

{$ifndef cus_input}
{$Endif}
{$ifdef cus_input}
{$Endif}

procedure stampa_large(x,y:integer;buff:fatt);
begin
  gotoxy(x,y);
  clreop;
  stampa_buff(buff);
  wait;
end;


procedure stampa_in_testo(st,s:string);
{stampa il file base di nome st in file testo con i record scritti}
var base:fof;
    k:boolean;
begin
  menu(1,'Converte il file base di nome st in file testo con i record scritti');
  repeat
    if present(s) then begin
      code:=3;
      centre(10,'il file `'+s+'` esiste (!!)');
      centre(11,'Non posso convertire il file senza un file temporaneo');
      gets(10,12,30,'Nome per un file temporaneo(verra` cancellato al termine)',s,code);
    end;
  until not(present(s)) or (code=3);
  if not (present(s)) then begin
      assign(base,st);
      reset(base);
      seek(base,0);
      assign(config,s);
      rewrite(config);
      while not(eof(base)) do begin
	read(base,buff);
	if cutlr(buff.riga)<>'' then
	writeln(config,cutlr(buff.riga));
      end;
      close(config);
      close(base);
      centre_wait(10,'Operazione conclusa');
    end else
       centre_wait(10,'Operazione non effettuata');
end;

procedure converti_in_testo(st:string);
{converte il file base di nome st in file testo con i record scritti e lo cancella}
var base:fof;
    k:boolean;
    s:string;
begin
  menu(1,'Converte il file base di nome st in file testo con i record scritti');
  s:='qwaszx.erd';
  repeat
    if present(s) then begin
      code:=3;
      centre(10,'il file `'+s+'` esiste (!!)');
      centre(11,'Non posso convertire il file senza un file temporaneo');
      gets(10,12,30,'Nome per un file temporaneo(verra` cancellato al termine)',s,code);
    end;
  until not(present(s)) or (code=3);
  if not (present(s)) then begin
      assign(base,st);
      reset(base);
      seek(base,0);
      assign(config,s);
      rewrite(config);
      while not(eof(base)) do begin
	read(base,buff);
	writeln(config,buff.riga);
      end;
      close(config);
      close(base);
      erase(base);
      rename(config,st);
       centre_wait(10,'Operazione conclusa');
    end else
       centre_wait(10,'Operazione non effettuata');


end;
procedure fromtext; {importa da file testo ordinato}
var st2:string;

   code,c2:integer;

begin
  repeat
    code:=3;
    get_name2(10,10,30,'Filename?',st_name2,code);
    if present(st_name2) then begin
      assign(config,st_name2);
      reset(config);
      assign(base,st_name);
      reset(base);
      seek(base,filesize(base));
      while not(eof(config)) do begin
	azzera_buff(buff);
	readln(config,st);
      {while pos(chr(9),st)>0 do begin
        azzera_buff(buff);
        with buff do begin
	  riga:=cutlr(copy(st,1,15));
	  cogriga:=cutlr(copy(st,16,13));
	  tel:=cutlr(copy(st,29,12));
	  info:=cutlr(copy(st,41,31));
	  compl:=cutlr(copy(st,72,11));
	  telwork:=cutlr(copy(st,83,25));
	end;
	clrscr;
	stampa_buff(buff);
	c2:=0;
	gets(10,22,120,'',st,c2);
      end;
      azzera_buff(buff);

      with buff do begin
	riga:=cutlr(copy(st,1,15));
	cogriga:=cutlr(copy(st,16,13));
	tel:=cutlr(copy(st,29,12));
	info:=cutlr(copy(st,41,31));
	compl:=cutlr(copy(st,72,11));
	telwork:=cutlr(copy(st,83,25));
      end;}
      buff.riga:=copy(st,1,length(st));
      write(base,buff);
      end;
      close(config);
      close(base);
      mid('operazione Conclusa');
      wait;
    end
    else   begin
      mid('L`archivio non esiste!');
      wait;
      code:=0;
    end;
  until ((code=0) and present(st_name2)) or (code=3);

end;

procedure fromfile(source,dest:string;onbase,rwr,ontext,rwrt:boolean);
var setfile,config:text;
var s,stx:string;
    x,a,s1,s2:integer;
    c1,c2,c3,c4,c5:char;
    set1,set2:set of char;
begin
  c1:=chr(34);
  c2:=chr(39);
  set1:=['a'..'z','A'..'Z','0'..'9','_','-','.'];
  set2:=[' ',':',c1,c2,'<','>','/'];
  if onbase then begin
    assign(base,dest);
    if rwr or not(present(dest)) then begin
      centre(9,'I dati verrano scritti nel file '+dest);
      if present(dest) and (dest=st_name) and rwr then
	get_boo(10,10,'Davvero vuoi cancellare l`archivio centrale `'+st_name+'`?',rwr)
      else begin
	if present(dest) and rwr then
	  get_boo(10,10,'Sicuro di cancellare l`archivio `'+dest+'`?',rwr)
	else begin
	  if rwr then
	    rewrite(base)
	  else begin
	    reset(base);
	    seek(base,filesize(base));
	  end;
	  if not(present(dest)) and rwr then
	    rewrite(base);
	end;
      end;
    end else begin
	reset(base);
	seek(base,filesize(base));
    end
  end else
    if ontext then begin
      assign(config,dest);
      if rwrt then begin
	get_boo(10,10,'Davvero vuoi cancellare il file '+dest+'?',rwrt);
	if rwrt then
	  rewrite(config)
	else begin
	  get_name(10,14,'Nome file testo di destinazione?',dest);
	  append(config);
	end
      end else
	append(config);
     end;
  assign(setfile,source);
  reset(setfile);

  x:=0;
  while not(eof(setfile)) do begin
    x:=x+1;
    readln(setfile,s);
    s:=cutlr(s);
    while pos('@',s)>0 do begin
      a:=pos('@',s);
      while a>0 do begin
	dec(a);
	if s[a] in set1 then
	  s1:=a
	else begin s1:=a+1; a:=0; end;
      end;
      s:=copy(s,s1,255);
      a:=pos('@',s);
      while a<256 do begin
	inc(a);
	if s[a] in set1 then
	  s1:=a
	else begin s1:=a-1; a:=256; end;
      end;
      if epos('@',s,s1)<>0 then begin
	stx:=copy(s,1,s1);
	if ontext then writeln(config,stx);
	if onbase then begin
	  buff.riga:=stx;
	  write(base,buff);
	end;
	s:=copy(s,s1+1,255);
      end else begin
	if ontext then writeln(config,copy(s,1,s1));
	if onbase then begin
	    buff.riga:=copy(s,1,s1);
	    write(base,buff);
	end;
	s:='';
      end;
    end; {while linea}

  end; {while file}

  if onbase then
    close(base)
  else
   close(config);
  close(setfile);
  message2('finito con '+source,1,1);
end;

procedure inport_from_file(source,dest:string);
var setfile,config:text;
var s,stx:string;
    x,a,s1,s2:integer;
    c1,c2,c3,c4,c5:char;
    set1,set2:set of char;
begin
  c1:=chr(34);
  c2:=chr(39);
  set1:=['a'..'z','A'..'Z','0'..'9','_','-','.'];
  set2:=[' ',':',c1,c2,'<','>'];
  assign(base,dest);
  reset(base);
  seek(base,filesize(base));
  assign(setfile,source);
  reset(setfile);
  x:=0;
  while not(eof(setfile)) do begin
    x:=x+1;
    readln(setfile,s);
    s:=cutlr(s);
    while pos('@',s)>0 do begin
      a:=pos('@',s);
      while a>0 do begin
	dec(a);
	if s[a] in set1 then
	  s1:=a
	else begin s1:=a+1; a:=0; end;
      end;
      s:=copy(s,s1,255);
      a:=pos('@',s);
      while a<256 do begin
	inc(a);
	if s[a] in set1 then
	  s1:=a
	else begin s1:=a-1; a:=256; end;
      end;
      if epos('@',s,s1)=0 then begin
	stx:=copy(s,1,s1);
	buff.riga:=stx;
	write(base,buff);
	s:=copy(s,s1+1,255);
      end else begin
	 buff.riga:=copy(s,1,s1);
	 write(base,buff);
      end;
      s:='';
      end;

  end; {while file}
  close(base);
  close(setfile);
  writeln('finito con '+source);
end;

procedure inport_text;
const prgid='.7ba';
var    h,a,b,n,code,count:integer;
       st,s1,s2,s3,s4:string;
       chr1:char;
       auto,new,ontext:boolean;
       config:text;

begin
  load_conf(prgid);
  new:=false;
  count:=1;
  n:=80;
  if paramcount=0 then begin {menu ins}
    repeat
      code:=3;
      case count of
	1:  repeat
	       menu(1,'Programma di composizione file di email');
	       centre(3,'Questo programma estrae gli indirizzi e-mail da un file testo singolo');
	       centre(4,'e li agginge nel database od in un altro archivio testo');
	       input_name(10,10,1,'File sorgente?',st_name2,code);
		if present(st_name2) and (code<>3) then begin
		 assign(config,st_name2);
		 reset(config);
		 clrscr;
		 for n:=1 to 20 do
		   if not(eof(config)) then begin
		     readln(config,st);
		     writeln(copy(st,1,79));
		   end;
		 writeln;
		 close(config);
		 chr1:='s';
		 get_chr(1,24,'E` questo il file sorgente?',chr1);
	       end;
	     until (chr1 in ['s','S']) or (code=3);
      2:repeat
	  if st_name='' then
	    st_name:=st_name2;
	  clrscr;
	  input_name(10,12,0,'File destinazione?',st_name,code);
	  if code=3 then begin
	    ch:='s';
	    get_chr(10,13,'Vuoi interrompere l`operazione?',ch);
	    if upcase(ch)<>'s' then begin
	      new:=false;
	      code:=0;
	    end;
	  end;
	  if st_name=st_name2 then
	    message('Nome Files sorg. e dest. non possono essere uguali',1,1);
	 until (st_name2<>st_name) or (code=3);
      3: begin
	   code:=0;
	   ontext:=false;
	   get_boo(10,14,'Vuoi creare un file testo?',ontext);

	 end;

    end;
    if code=0 then
      inc(count)
    else
      dec(count);
  until not(ranged(count,1,3));
  if code=0 then
    fromfile(st_name2,st_name,not(ontext),new,ontext,false);
  end
  else begin { linea comandi}
    code:=0;
    st_name:=paramstr(1);
    st_name2:=paramstr(2);
    case paramcount of
       1,2:fromfile(st_name2,st_name,true,false,false,new);
       3:begin
	   n:=int_val(paramstr(3));
	   fromfile(st_name,st_name2,true,false,true,new);
	 end;
       1,2,4:writeln(' Parametri insufficienti o di troppo');
       5,6:begin
	  n:=int_val(paramstr(3));
	  a:=int_val(paramstr(4));
	  b:=int_val(paramstr(5));
	  if (paramcount=6) and (paramstr(6)='/a') then
	    auto:=true
	  else auto:=false;
	  h:=0;
	  for code:=1 to length(st_name) do
	    if st_name[code]='?' then inc(h); {cerca num.car da sost.}
	  if h>0 then begin
	    s1:=copy(st_name,1,pos('?',st_name)-1);  {copie per elab.}
	    s2:=copy(st_name,pos('?',st_name)+h,255);
	    s3:=copy(st_name2,1,pos('?',st_name2)-1);
	    s4:=copy(st_name2,pos('?',st_name2)+h,255);
	    for count:=a to b do begin
	      st_name:=s1+stst2(count,h,0)+s2;
	      st_name2:=s3+stst2(count,h,0)+s4;
	      chr1:='S';
	      if not auto then
		get_Chr(10,10,'Procedo con files "'+st_name+'" e "'+st_name2+'" ?',chr1);
	      if upcase(chr1)='S' then
		fromfile(st_name2,st_name,true,false,true,new);
	     end;
	  end
	  else message2('errore nel parametri 1 o 2 ,mancano i car. ??',1,1);
	 end;
    else message2('Parametri incongruenti',1,1);
  end;

  end;
  save_conf(prgid);
end;

{ATTENZIONE!!!! questa e' stata messa solo per far girare il programma}
procedure wr(a:integer;s:string);
begin
  if a=1 then write(s);
end;


{$ifndef cus_stampe}
{$i \tp\stand\conf_2}
{i  \tp\stand\procpr10}
{$endif}
procedure scan_fileprint(a,b,c,d,e:string;k:boolean);
begin
 mid('funzione non attiva');
end;
{$i  \tp\stand\proc2}
{i \tp\stand\get_arg}
procedure cref(var st_name:string);
var con,code:integer;
begin
          menu(1,'Creazione file '+atoms+' con nome numerico');
          ok:=false;

          repeat
            code:=3;
            get_name2(10,10,12,'Filename?',st_name,code);
            if present(st_name) and (code=0) then begin
              message('Esiste gi… un archivio con questo nome',1,0);
              tasto:='n';
              get_chr(20,20,'Continuo?',tasto);
              if tasto='s' then
                ok:=true;
            end;

          until not(present(st_name)) or ok or (code=3);
          if (code=0) and ok then begin
            get_int(10,12,'Quanti record devo creare?',i);
            message('1 per ordine ascendente,2 per casuale altro per discendente',1,0);
            get_int(10,14,'Inserire codice:',y);
            if i<>0 then begin
              assign(base,st_name);
              rewrite(base);
              azzera_buff(buff);
              mid('creo');
              if (y=1) or (y=2) then begin
                x:=1;
                con:=1;
                now:=1;
              end
              else begin
                x:=1;
                con:=-1;
                now:=i;
              end;
              while (x<>i) do begin
               if y<>2 then begin
                 buff.riga:=sts(now);
                   case now of
                     1..9:buff.riga:='00'+buff.riga;
                     10..99:buff.riga:='0'+buff.riga;
                   end;
                end
                else
                  buff.riga:=sts(random(i));
                write(base,buff);
                x:=x+1;
                writexy(1,24,'Creato record num.:'+sts(x));
                now:=now+con;
              end;
              close(base);
            end;
          end;
end;

{$i  \tp\stand\archivio}
procedure fromdir;
var lista:text;
     list_name:string;
    attuale:boolean;

procedure crea_lista_archivi(var list_name:string);
var code:integer;
begin
   code:=0;
   gets(1,5,30,'Nome file testo con la lista degli archivi da filtrare:',list_name,code);
end;

begin
  menu(1,'Estrazione e-mail da diversi file');
  list_name:='';
  attuale:=true;
  crea_lista_archivi(list_name);
  if (list_name<>'') and present(list_name) then begin
    get_boo(1,10,'Utilizzo l`attuale file di database per memorizzare i nuovi indirizzi?',attuale);
    if not(attuale) then
      archivio(st_name);
    assign(lista,list_name);
    reset(lista);
    while not(eof(lista)) do begin
      readln(lista,st_name2);
      if present(st_name2) then
	inport_from_file(st_name2,st_name);
    end;
    close(lista);
  end else
    mid('Nessuna lista di file da filtrare: operazione interotta.');
end;

procedure add_fix_addr;
var st:string;
   code:integer;
   k:boolean;
   {recfile Š definito in unit sort}
   bas2:fof;
   old2:fatt;

begin
  menu(1,'Estrazione domini');
  centre(5, 'Creo un destinatario fisso per ogni dominio');
  get_name(10,7,'File testo destinazione?',st_name2);
  st:='webmaster';
  code:=3;
  gets(10,9,20,'Destinatario fisso?',st,code);
  k:=true;
  st:=cutlr(st);
  centre(10,'Per ogni dominio in '+st_name+' creo utente `'+st+'` nel file testo '+st_name2);
  get_boo(10,12,'Procedo?',k);
  if k then begin
    assign(base,st_name);
    reset(base);
    assign(recfile,st_name2);
    rewrite(recfile);
    while not(eof(base)) do begin
      read(base,buff);
      buff.riga:=st+copy(buff.riga,pos('@',buff.riga),255);
      write(recfile,buff);
    end;

    get_boo(10,14,'Procedo con la elimanzione dei doppioni e degli indirizzi esteri?',k);
    if k then begin

      reset(recfile);
      qs(0,filesize(recfile)-1);
      if not(present('qwaszxer.dfc')) then begin
	st:='.it';
	gets(5,16,10,'Se vuoi puoi ora inserire un testo filtro sul finale dominio ?',st,code);
	assign(bas2,'qwaszxer.dfc');
	rewrite(bas2);
	azzera_buff(buff);
	azzera_buff(old);
	seek(recfile,0);
	while not(eof(recfile)) do begin
	  old2:=old;
	  old:=buff;
	  read(recfile,buff);
	  centre(10,'  '+buff.riga+'  '+copy(buff.riga,length(buff.riga)-length(st),length(st))+'  '+st+'  ');
	   if ((cutlr(key_buff(buff))<>cutlr(key_buff(old)))) {or ((buff.serie<>old.serie))}
	   and not(comp_buff(buff,old2,code)=0)  and
	   {filtro} (copy(buff.riga,length(buff.riga)-length(st)+1,length(st))=st)
	   then begin
	    posit:=-2;
	    write(bas2,buff);
	    {stampa_buff(buff);}
	  end
	  else
	  message('elminato rec '+sts(filepos(base)),1,0);
	end;
	close(bas2);
        close(recfile);
	erase(recfile);
	rename(bas2,st_name2);
	converti_in_testo(st_name2);
	writexy(60,6,'Fine operazione');
	reset(recfile);
      end else begin
	centre(24,'Incredibile! File `qwaszxer.dfc` presente nella directory');
	message2('non posso continuare',1,1);
      end;
    end;
    close(recfile);
  end;
end;
procedure dom_from_db;
begin
  assign(base,st_name);
end;


procedure utility(var st_name:string);{questa procedure deve sempre essere presente
al limite nulla pa dichiarata (altrimkenti bisogna modificare il main program
uscendo dallo standard}
var code:integer;
begin {utility}
  repeat
    menu(1,'Utility');
    centre(6,rsped('1) Creazione svuotamento/archivio',50));
    centre(7,rsped('2) Creazione files '+atoms+' a codice numerico',50));
    centre(8,rsped('3) Ridimensionamento Descrizioni ',50));
    centre(9,rsped('4) Zap',50));
    {centre(10,rsped('5) Importa da archivio testo di soli indirizzi',50));}
    centre(11,rsped('6) Recupera indirizzi da insieme di file',50));
    centre(12,rsped('7) Estrai indirizzi da file testo o bookmark',50));
    centre(13,rsped('8) Aggiungi destinatario standard per ogni domain',50));
    centre(14,rsped('9) Estrai destinatari di un certo dominio',50));
    centre(15,rsped('R) Riordina e compatta l`archivio',50));
    centre(16,rsped('S) Stampa l`archivio su file testo',50));
    getrchrb(60,20,'0','z','Scelta?',tasto);
    case tasto of
      '1':begin
            archivio(st_name);
            assign(base,st_name);
            rewrite(base);
            close(base);
          end;
      '2':cref(st_name);
      {$ifdef zap }
      '4':zap(st_name,'\listini','conv','file','conv.rep');
      {$endif}
      '6':fromdir;
      '7':begin
	    save_conf(prgid);
	    inport_text;
	    load_conf(prgid);
	  end;
      '8':add_fix_addr;
      '9':dom_from_db;
      'R':begin
	    quicksort(st_name,0,ok);
	    del_dup2(st_name,0,ok);
	  end;
      'S':stampa_in_testo(st_name,'temp.tmp');

    else
     message2('Opzione non abilitata',1,1);
    end;

  until tasto='0';
end;



procedure menu1;
var code:integer;
begin

{  exec('\turbo4\exe\menu1.exe',' '+prgid+' '+relase+' '+atoms+' '+sts(men_w)+' '+st_name);}


  menu(1,'Gest '+atoms+' '+relase+ ' by Loris    prgid='+prgid);
  pub_arc(50,3);
  centre(07,rsped('1) Selezione archivio',men_w));
  centre(08,rsped('2) Lista '+atoms+' presenti in archivio',men_w));
  centre(09,rsped('3) Aggiunta '+atoms+' in fondo all`archivio',men_w));
  centre(11,rsped('5) Inserisci/Modifica/Cancella '{+atoms+' in archivio'},men_w));
  centre(12,rsped('6) Stampa '+atoms+' su carta',men_w));
  centre(13,rsped('7) Utilita`',men_w));
  {centre(14,rsped('8) Lista archivi '+atoms,men_w));}
  {$ifdef sorts}
  centre(15,rsped('9) Gestione archivio',men_w));
  {$endif}

  centre(17,rsped('0) Uscita dalla Gestione '+atoms,men_w));

  tasto:=' ';
  code:=3;
  getrchr(40,23,'0','A','Scelta? ',tasto,code);
  if code=3 then
    tasto:='0';
  val(tasto,i,pos_r);
end;


procedure main;
begin{per permettre l'include del programma principale esso viene messo in una procedura}
  load_conf(prgid);
  {config_printer(prgid);}
   x:=0;y:=0;i:=0;posit:=0;pos_r:=0;
   tasto:='_';
   {$ifdef strc}
   riga:='';
   {$endif}
  {$ifdef pr_ix}
  pr_ix:=1;
  {$endif}
  clrscr;
  repeat

    if not(present(st_name)) then
      archivio(st_name);

    if file_ord[0] and not(file_ord[1]) and present(st_name) then begin
      mid('L`archivio Š in disordine ;sarebbe opportuno ordinarlo.');
      message2('Premere un tasto',1,0);
    end;
  until present(st_name);
  st:='';
  repeat
    azzera_buff(buff);
    buff:=null_rec;

    posit:=-1;
    menu1;
    case i of
      1:archivio(st_name);
      2:operation(st_name,1);
      3:inserisci(st_name);
      5:menu_m_c(st_name);
      {$ifdef cus_stampe}  6:menu_stampe(st_name); {$endif}
      {$ifndef cus_stampe}  6:scan_fileprint(st_name,'','','','',false); {$endif}
      7:utility(st_name);
      {$ifdef sorts}
      9:menu_sorts(st_name);
      {$endif}
    end;
  until i=0;
  mid('arrivederci');
  save_conf(prgid);
end;
BEGIN {program}
  st:='';
  LPTNAME:='ldef';
  Localita:='';
  main;
end.