Menu
▾
▴
[Acdo-commit] CVS: acdo/src/pkg Makefile,NONE,2.0 base_datos.adb,NONE,2.0 base_datos.ads,NONE,2.0 datos.ads,NONE,2.0 dispositivo.ads,NONE,2.0 infofich.c,NONE,2.0 preferencias.adb,NONE,2.0 preferencias.ads,NONE,2.0 ustrings.adb,NONE,2.0 ustrings.ads,NONE,2.0 utiles.adb,NONE,2.0 utiles.ads,NONE,2.0
|
From: Cesar P. T. <or...@us...> - 2001-05-10 19:59:35
|
Update of /cvsroot/acdo//acdo/src/pkg
In directory usw-pr-cvs1:/tmp/cvs-serv9661/src/pkg
Modified Files:
Tag: 2.0
Makefile base_datos.adb base_datos.ads datos.ads
dispositivo.ads infofich.c preferencias.adb preferencias.ads
ustrings.adb ustrings.ads utiles.adb utiles.ads
Log Message:
cambio de revisión
--- NEW FILE ---
all:
clean:
rm -f *.o *~ *.ali
--- NEW FILE ---
-----------------------------------------------------------------------------
-- TILDURE
-- Autor: Juan Manuel Perié Buil (44...@ce...)
-- Fichero: base_datos.adb
-- Fecha: 25 de abril de 2001
-- Proyecto: acdo
-- Descripción: Transacciones de la base de datos de acdo (implementación)
-----------------------------------------------------------------------------
with postgresql; use postgresql;
with preferencias; use preferencias;
package body base_datos is
type tpestado is (DESCONECTADO, CONECTADO, CONSULTADO);
type tpbuscado is (FICHEROS, TEMAS, VOLUMENES, SUBDIRS, SUBFICH);
-- Si la última búsqueda es:
-- · un fichero con unos criterios
-- · la lista de temas
-- · los volumenes de un tema
-- · los subitems de un directorio (primero directorios)
-- · los subitems de un directorio (después ficheros)
conexion : tppgconexion;
resultado : tppgresultado;
fila : integer; -- La que está lista para leer
estado : tpestado := DESCONECTADO;
buscado : tpbuscado;
resultado_fich : tppgresultado; -- En búsquedas de subitems, los directorios
-- se pondrán en resultado y los ficheros
-- en resultado_fich
procedure conectar is
p : tppreferencias;
begin
preferencias.dar(p);
if estado /= DESCONECTADO then
desconectar(conexion);
else
conectar(conexion,
S(p.bd_servidor),
Integer'image(p.bd_puerto),
S(p.bd_nombre),
S(p.bd_usuario),
S(p.bd_password));
end if;
estado := CONECTADO;
end conectar;
procedure desconectar is
begin
if estado = DESCONECTADO then
raise ERROR_ESTADO;
else
desconectar(conexion);
estado := DESCONECTADO;
end if;
end desconectar;
procedure insertar(item: tpitem; identificador : out integer) is
-- Devuelve el identificador del item encontrado
resultado_id : tppgresultado;
p : tppreferencias;
begin
dar(p);
if estado /= CONECTADO then
raise ERROR_ESTADO;
else
case item.tipo is
when VOLUMEN =>
consulta(conexion, resultado_id, "begin;");
consulta(conexion, resultado_id, "insert into volumen(titulo,tema," &
"fecha,codigo,medio,descripcion) values ('" &
S(item.titulo) & "','" & S(item.tema) & "','" &
S(item.fecha_insercion) & "','" &
S(item.codigo) & "','" & S(p.medio) & "','" &
S(item.descripcion) & "');");
consulta(conexion,resultado_id,
"select currval('volumen_idvol_seq');");
-- No hay condición de carrera. currval es almacenado en cada uno
-- de los back-ends del servidor.
if num_filas(resultado_id) /= 1 then
identificador := -1;
consulta(conexion, resultado_id, "rollback;");
else
identificador := Integer'value(S(campo(resultado_id, 1, 1)));
consulta(conexion, resultado_id, "commit;");
end if;
when DIRECTORIO =>
consulta(conexion, resultado_id, "begin;");
consulta(conexion, resultado_id, "lock table volumen in share mode;");
consulta(conexion, resultado_id,
"lock table directorio in exclusive mode;");
consulta(conexion, resultado_id, "select idvol from volumen where " &
"idvol = '" & Integer'image(item.volumen) & "';");
if num_filas(resultado_id) /= 1 then
identificador := -1;
consulta(conexion, resultado_id, "rollback;");
else
if item.padre_dir /= -1 then
-- Es un directorio normal
consulta(conexion, resultado_id, "select iddir from directorio " &
"where iddir = '" & Integer'image(item.padre_dir) & "';");
if num_filas(resultado_id) /= 1 then
identificador := -1;
consulta(conexion, resultado, "rollback;");
else
consulta(conexion, resultado_id, "insert into directorio(" &
"nombre,nombre_completo,fecha,tamanyo,idVol," &
"idPadre) values ('" & S(item.nombre_dir) & "','" &
S(item.nombre_completo_dir)&"','" & S(item.fecha_dir) &
"'," & Integer'image(item.tamanyo_dir) & ",'" &
Integer'image(item.volumen) & "','" &
Integer'image(item.padre_dir) & "');");
consulta(conexion, resultado_id,
"select currval('directorio_iddir_seq');");
if num_filas(resultado_id) /= 1 then
identificador := -1;
consulta(conexion, resultado, "rollback;");
else
identificador := Integer'value(S(campo(resultado_id, 1,1)));
consulta(conexion, resultado, "commit;");
end if;
end if;
else
-- Es un directorio raiz
consulta(conexion, resultado_id, "insert into directorio(" &
"nombre,nombre_completo,fecha,tamanyo,idVol," &
"idPadre) values ('" & S(item.nombre_dir) & "','" &
S(item.nombre_completo_dir) & "','" & S(item.fecha_dir) &
"'," & Integer'image(item.tamanyo_dir) & ",'" &
Integer'image(item.volumen) & "',-1);");
consulta(conexion, resultado_id,
"select currval('directorio_iddir_seq');");
if num_filas(resultado_id) /= 1 then
identificador := -1;
consulta(conexion, resultado, "rollback;");
else
identificador := Integer'value(S(campo(resultado_id, 1,1)));
consulta(conexion, resultado_id, "update volumen set idraiz = "&
integer'image(identificador) & " where idvol = " &
integer'image(item.volumen) & ";");
consulta(conexion, resultado, "commit;");
end if;
end if;
end if;
when FICHERO =>
consulta(conexion, resultado_id, "begin;");
consulta(conexion, resultado_id, "lock table directorio " &
"in share mode;");
consulta(conexion, resultado_id, "select iddir from directorio " &
"where iddir = '" & Integer'image(item.padre_fich) & "';");
if num_filas(resultado_id) /= 1 then
identificador := -1;
consulta(conexion, resultado_id, "rollback;");
else
consulta(conexion, resultado_id, "insert into fichero(nombre," &
"fecha,tamanyo,iddir) values ('" & S(item.nombre_fich) &
"','" & S(item.fecha_fich) & "'," &
Integer'image(item.tamanyo_fich) & "," &
Integer'image(item.padre_fich) & ");");
consulta(conexion, resultado_id,
"select currval('fichero_idfich_seq');");
if num_filas(resultado_id) /= 1 then
identificador := -1;
consulta(conexion, resultado_id, "rollback;");
else
identificador := Integer'value(S(campo(resultado_id, 1, 1)));
consulta(conexion, resultado_id, "commit;");
end if;
end if;
end case;
end if;
end insertar;
procedure modificar(item: tpitem) is
resultado_id : tppgresultado;
begin
if estado = DESCONECTADO then
raise ERROR_ESTADO;
else
if item.tipo = VOLUMEN then
consulta(conexion, resultado_id, "update volumen set titulo = '" &
S(item.titulo) & "', tema = '" & S(item.tema) & "', fecha = '"
& S(item.fecha_insercion) & "', codigo = '" & S(item.codigo) &
"', medio = '" & S(item.tipo_dispositivo)&"', descripcion = '"&
S(item.descripcion) & "' where idvol = " &
Integer'image(item.identificador) & ";");
else
consulta(conexion, resultado_id, "update directorio set nombre = '" &
S(item.nombre_dir) & "', nombre_completo='" &
S(item.nombre_completo_dir) & "', fecha='" &
S(item.fecha_dir) & "', tamanyo='" &
integer'image(item.tamanyo_dir) & "' where idDir = " &
integer'image(item.identificador) & ";");
end if;
end if;
end modificar;
procedure borrar(item: tpitem) is
res : tppgresultado;
idvol : ustring;
begin
if estado = DESCONECTADO then
raise ERROR_ESTADO;
else
if item.tipo = VOLUMEN then
idvol := U(integer'image(item.identificador));
consulta(conexion, res, "begin;");
consulta(conexion, res, "lock table volumen in exclusive mode;");
consulta(conexion, res, "lock table directorio in exclusive mode;");
consulta(conexion, res, "lock table fichero in exclusive mode;");
consulta(conexion, res, "delete from fichero where idDir in " &
"(select iddir from directorio where idvol = " & S(idvol) &
");");
consulta(conexion, res, "delete from directorio where idvol = '"
& S(idvol) & "';");
consulta(conexion, res, "delete from volumen where idvol = '" &
S(idvol) & "';");
consulta(conexion, res, "commit;");
end if;
end if;
end borrar;
procedure buscar(criterios: tpbusqueda) is
-- Busca ficheros
condicion : ustring;
sentencia : ustring;
begin
if estado = DESCONECTADO then
raise ERROR_ESTADO;
else
condicion := U("");
if S(criterios.nombre) /= "" then
condicion := U(S(condicion) & " and (fichero.nombre like '%" &
S(criterios.nombre) & "%')");
end if;
if S(criterios.fecha_ant) /= "" then
condicion := U(S(condicion) & " and (fichero.fecha <= '" &
S(criterios.fecha_ant) & "')");
end if;
if S(criterios.fecha_post) /= "" then
condicion := U(S(condicion) & " and (fichero.fecha >= '" &
S(criterios.fecha_post) & "')");
end if;
if criterios.tama_menor /= 0 then
condicion := U(S(condicion) & " and (fichero.tamanyo <= '" &
integer'image(criterios.tama_menor) & "')");
end if;
if criterios.tama_mayor /= 0 then
condicion := U(S(condicion) & " and (fichero.tamanyo >= '" &
integer'image(criterios.tama_mayor) & "')");
end if;
if S(criterios.tema) /= "" then
condicion := U(S(condicion) & " and (fichero.tema = '" &
S(criterios.tema) & "')");
end if;
if S(criterios.codigo) /= "" then
condicion := U(S(condicion) & " and (fichero.codigo = '" &
S(criterios.codigo) & "')");
end if;
if S(criterios.medio) /= "" then
condicion := U(S(condicion) & " and (fichero.medio = '" &
S(criterios.medio) & "')");
end if;
-- En condicion tenemos el where
sentencia := U("select fichero.nombre, fichero.tamanyo, fichero.fecha," &
"directorio.nombre_completo, volumen.titulo from " &
"fichero,directorio,volumen where " &
"(fichero.iddir = directorio.iddir) and " &
"(directorio.idvol = volumen.idvol) " & S(condicion) & ";");
consulta(conexion, resultado, S(sentencia));
fila := 1;
estado := CONSULTADO;
buscado := FICHEROS;
end if;
end buscar;
procedure buscar is
-- Busca los temas
begin
if estado = DESCONECTADO then
raise ERROR_ESTADO;
else
consulta(conexion, resultado, "select distinct tema from volumen;");
fila := 1;
estado := CONSULTADO;
buscado := TEMAS;
end if;
end buscar;
procedure buscar(tema: ustring) is
-- Busca volumenes de un tema
begin
if estado = DESCONECTADO then
raise ERROR_ESTADO;
else
consulta(conexion, resultado, "select idvol,titulo,tema,fecha, " &
"codigo,medio,descripcion,idraiz from volumen where tema = '" &
S(tema) & "';");
fila := 1;
estado := CONSULTADO;
buscado := VOLUMENES;
end if;
end buscar;
procedure buscar(item: tpitem) is
-- Busca subitems de un item
begin
if estado = DESCONECTADO then
raise ERROR_ESTADO;
else
if item.tipo = DIRECTORIO then
consulta(conexion, resultado, "select iddir, nombre, nombre_completo," &
"fecha, tamanyo, idVol, idPadre from directorio where " &
"iddir = " & integer'image(item.identificador) & ";");
consulta(conexion, resultado_fich, "select idfich, nombre, fecha," &
"tamanyo,iddir from fichero where iddir = " &
integer'image(item.identificador) & ";");
else
-- Es un volumen
consulta(conexion, resultado, "select iddir, nombre, nombre_completo," &
"directorio.fecha, tamanyo, directorio.idVol, idPadre from " &
"volumen,directorio where (directorio.iddir = volumen.idraiz)"&
" and (directorio.idvol = " &
integer'image(item.identificador) & ");");
consulta(conexion, resultado_fich, "select idfich, fichero.nombre, " &
"fichero.fecha,fichero.tamanyo,fichero.iddir from fichero," &
"directorio where (fichero.iddir = directorio.iddir) " &
"and (directorio.idpadre = -1) and (directorio.idvol = " &
integer'image(item.identificador) & ");");
end if;
estado := CONSULTADO;
buscado := SUBDIRS;
fila := 1;
end if;
end buscar;
-- Cuando fin sea true en item no habrá nada
procedure recuperar(item: out tpitem_access; fin: out boolean) is
-- Para recuperar items
begin
if estado /= CONSULTADO then
raise ERROR_ESTADO;
else
case buscado is
when FICHEROS =>
-- Recupera en otro recuperar
raise ERROR_ESTADO;
when TEMAS =>
-- Recupera en otro recuperar
raise ERROR_ESTADO;
when VOLUMENES =>
if fila > num_filas(resultado) then
fin := true;
else
item := new tpitem(VOLUMEN);
item.identificador := integer'value(S(campo(resultado,fila,1)));
item.titulo := campo(resultado,fila,2);
item.tema := campo(resultado,fila,3);
item.fecha_insercion := campo(resultado,fila,4);
item.codigo := campo(resultado,fila,5);
item.tipo_dispositivo := campo(resultado,fila,6);
item.descripcion := campo(resultado,fila,7);
item.dir_raiz := integer'value(S(campo(resultado,fila,8)));
fin := false;
fila := fila + 1;
end if;
when SUBDIRS =>
if fila > num_filas(resultado) then
fila := 1;
buscado := SUBFICH;
recuperar(item,fin);
else
item := new tpitem(DIRECTORIO);
item.identificador := integer'value(S(campo(resultado,fila,1)));
item.padre_dir := integer'value(S(campo(resultado,fila,7)));
item.nombre_dir := campo(resultado,fila,2);
item.nombre_completo_dir := campo(resultado,fila,3);
item.tamanyo_dir := integer'value(S(campo(resultado,fila,5)));
item.fecha_dir := campo(resultado,fila,4);
fin := false;
fila := fila + 1;
end if;
when SUBFICH =>
if fila > num_filas(resultado_fich) then
fin := true;
else
item := new tpitem(FICHERO);
item.identificador := integer'value(S(campo(resultado_fich,
fila,1)));
item.padre_fich := integer'value(S(campo(resultado_fich,fila,5)));
item.nombre_fich := campo(resultado_fich,fila,2);
item.tamanyo_fich:=integer'value(S(campo(resultado_fich,fila,4)));
item.fecha_fich := campo(resultado_fich,fila,3);
fin := false;
fila := fila + 1;
end if;
end case;
end if;
end recuperar;
procedure recuperar(tema: out ustring; fin: out boolean) is
-- Para recuperar temas
begin
if estado /= CONSULTADO or buscado /= TEMAS then
raise ERROR_ESTADO;
else
if fila > num_filas(resultado) then
fin := true;
else
tema := campo(resultado,fila,1);
fin := false;
fila := fila + 1;
end if;
end if;
end recuperar;
procedure recuperar(fichero: out tpbusqresul; fin: out boolean) is
begin
if estado /= CONSULTADO or buscado /= FICHEROS then
raise ERROR_ESTADO;
else
if fila > num_filas(resultado) then
fin := true;
else
fichero.nombre_fich := campo(resultado, fila, 1);
fichero.tamanyo_fich := integer'value(S(campo(resultado, fila, 2)));
fichero.fecha_fich := campo(resultado, fila, 3);
fichero.nombre_completo_dir := campo(resultado, fila, 4);
fichero.titulo := campo(resultado, fila, 5);
fin := false;
fila := fila + 1;
end if;
end if;
end recuperar;
end base_datos;
--- NEW FILE ---
-----------------------------------------------------------------------------
-- TILDURE
-- Autor: Juan Manuel Perié Buil (44...@ce...)
-- Fichero: Base_datos.ads
-- Fecha: 24 de abril de 2001
-- Proyecto: acdo
-- Descripción: Transacciones de la base de datos de acdo
-----------------------------------------------------------------------------
with datos; use datos;
with ustrings; use ustrings;
package base_datos is
ERROR_ESTADO : exception;
-- Se lanza cuando se he intentado hacer una consulta sin estar conectado,
-- cuando se accede a datos de una consulta no realizada o cuando se
-- intenta recuperar un tema que no se ha consultado
procedure conectar;
procedure desconectar;
procedure insertar(item: tpitem; identificador : out integer);
-- Devuelve el identificador del item encontrado
-- Si ha habido error devuelve -1 en identificador
-- Si se inserta un directorio raiz se debe poner item.padre_dir a -1
-- El medio lo saca de las preferencias
procedure modificar(item: tpitem);
-- item debe ser un volumen o directorio
-- modifica el item del identificador dado con el resto de los
-- datos del item
procedure borrar(item: tpitem);
procedure buscar(criterios: tpbusqueda);
-- Busca ficheros
procedure buscar;
-- Busca los temas
procedure buscar(tema: ustring);
-- Busca volumenes de un tema
procedure buscar(item: tpitem);
-- Busca subitems de un item
-- Cuando fin sea true en item no habrá nada
procedure recuperar(item: out tpitem_access; fin: out boolean);
-- Para recuperar items
procedure recuperar(tema: out ustring; fin: out boolean);
-- Para recuperar temas
procedure recuperar(fichero: out tpbusqresul; fin: out boolean);
-- Para recuperar busquedas
end base_datos;
--- NEW FILE ---
-----------------------------------------------------------------------------
-- TILDURE
-- Autor: Juan Manuel Perié Buil (44...@ce...)
-- Fichero: datos.ads
-- Fecha: 24 de abril de 2001
-- Proyecto: acdo
-- Descripción: Estructuras de datos de acdo
-----------------------------------------------------------------------------
with ustrings; use ustrings;
package datos is
type tptipo_item is (VOLUMEN,DIRECTORIO,FICHERO);
type tpitem(tipo : tptipo_item) is record
identificador : integer;
case tipo is
when VOLUMEN => titulo : ustring;
tema : ustring;
codigo : ustring;
descripcion : ustring;
fecha_insercion : ustring;
tipo_dispositivo : ustring;
dir_raiz : integer;
when DIRECTORIO => padre_dir : integer;
volumen : integer;
nombre_dir : ustring;
nombre_completo_dir : ustring;
tamanyo_dir : integer;
fecha_dir : ustring;
when FICHERO => padre_fich : integer;
nombre_fich : ustring;
tamanyo_fich : integer;
fecha_fich : ustring;
end case;
end record;
type tpitem_access is access tpitem;
type tppreferencias is record
ruta : ustring;
medio : ustring;
bd_usuario : ustring;
bd_password : ustring;
bd_servidor : ustring;
bd_puerto : integer;
bd_nombre : ustring;
administrador : boolean;
end record;
type tpbusqueda is record
nombre : ustring;
fecha_ant, fecha_post : ustring;
tama_menor, tama_mayor : integer; -- KBytes
tema : ustring;
codigo : ustring;
medio : ustring;
end record;
type tpbusqresul is record
nombre_fich : ustring;
tamanyo_fich : integer;
fecha_fich : ustring;
nombre_completo_dir : ustring;
titulo : ustring;
end record;
end datos;
--- NEW FILE ---
-----------------------------------------------------------------------------
-- TILDURE
-- Autor: Juan Manuel Perié Buil (44...@ce...)
-- Fichero: dispositivo.ads
-- Fecha: 24 de abril de 2001
-- Proyecto: acdo
-- Descripción: Módulo que inserta automáticamente un volumen en la base de
-- datos
-- Modificado por: César Pérez Turrado <44...@ce...>
-- Fecha modificación: 27 abril 2001
-- Motivo modificación: añadidas exepciones.
-----------------------------------------------------------------------------
with datos; use datos;
package dispositivo is
ERROR_FS : exception;
-- Se lanza cuando no se ha podido acceder al sistema de archivos.
ERROR_BD : exception;
-- Se lanza cuando ha habido algún error con la base de datos.
procedure insertar(volumen : tpitem);
end dispositivo;
--- NEW FILE ---
/********************************************************************
* TILDURE
* Autor: César Pérez Turrado (44...@ce...)
* Fichero: infofich.c
* Fecha: 30 de abril de 2001
* Proyecto: acdo
* Descripción: Funciones para obtener información de un fichero
* Estás funciones son conformes (al menos deberían) a:
* SVr4, SVID, POSIX, X/OPEN y BSD 4.3 + ansi C
********************************************************************/
#include <sys/stat.h>
#include <unistd.h>
#include <time.h>
#include <string.h>
#include <stdlib.h>
#include <locale.h>
#include <dirent.h>
#include <sys/types.h>
struct stDatosFichero {
char *nombre;
int tamanyo;
int directorio;
char *fecha;
int final;
};
static struct stDatosFichero datosFichero;
static DIR *dirinfo;
static struct dirent *fichinfo;
void abrirdirectorio (char *fichero)
{
dirinfo = opendir (fichero);
}
void leerdirectorio (char *fichero)
{
struct stat datos;
char c[300];
char *localizacion;
struct tm *fecha;
DIR *dirinfoAux;
char tmp[25];
localizacion = getenv ("LC_ALL");
setlocale(LC_ALL, localizacion);
fichinfo = readdir (dirinfo);
while (fichinfo != NULL && fichinfo->d_name[0] == '.') {
fichinfo = readdir (dirinfo);
}
if (fichinfo != NULL) {
datosFichero.final = 0;
sprintf (c, "%s/%s", fichero, fichinfo->d_name);
stat (c, &datos);
fecha = localtime (&datos.st_mtime);
strftime (tmp, 25, "%d/%m/%Y", fecha);
datosFichero.tamanyo = datos.st_size;
datosFichero.nombre = strdup (fichinfo->d_name);
datosFichero.fecha = strdup (tmp);
dirinfoAux = opendir (c);
if (dirinfoAux == NULL)
datosFichero.directorio = 0;
else
datosFichero.directorio = 1;
} else
datosFichero.final = 1;
}
int fichfinal ()
{
return (datosFichero.final);
}
char *fichnombre ()
{
return (datosFichero.nombre);
}
int fichdirectorio ()
{
return (datosFichero.directorio);
}
char *fichfecha ()
{
return (datosFichero.fecha);
}
int fichtamanyo ()
{
return (datosFichero.tamanyo);
}
--- NEW FILE ---
-----------------------------------------------------------------------------
-- TILDURE
-- Autor: César Pérez Turrado (44...@ce...)
-- Fichero: preferencias.adb
-- Fecha: 1 de mayo de 2001
-- Proyecto: acdo
-- Descripción: Módulo para la gestión de las preferencias del programa
-- segunda versión: no utiliza xml
-----------------------------------------------------------------------------
with datos; use datos;
with ustrings; use ustrings;
with ada.strings.fixed; use ada.strings.fixed;
with ada.strings.bounded; use ada.strings.bounded;
with ada.io_exceptions; use ada.io_exceptions;
with ada.sequential_io;
package body preferencias is
PACKAGE pcad255 IS NEW generic_bounded_length(255);
USE pcad255;
type tpSpreferencias is record
ruta: bounded_string;
medio: bounded_string;
bd_usuario: bounded_string;
bd_password: bounded_string;
bd_servidor: bounded_string;
bd_puerto: integer := 0;
bd_nombre: bounded_string;
administrador: boolean := false;
end record;
package esDatos is new ada.sequential_io(tpSpreferencias);
use esDatos;
type tpfDatos is new esDatos.file_type;
nfichero : constant string := "acdo.cfg";
p : tpSpreferencias;
procedure leer is
fichero: tpfDatos;
begin
open(fichero, in_file, nfichero);
read(fichero, p);
close(fichero);
exception
when others =>
p.ruta := to_bounded_string("");
p.medio := to_bounded_string("");
p.bd_usuario := to_bounded_string("");
p.bd_password := to_bounded_string("");
p.bd_servidor := to_bounded_string("");
p.bd_puerto := 0;
p.bd_nombre := to_bounded_string("");
p.administrador := false;
end leer;
procedure guardar(preferencias : tppreferencias) is
fichero: tpfDatos;
begin
create (fichero, out_file, nfichero);
p.ruta := to_bounded_string(ustrings.S(preferencias.ruta));
p.medio := to_bounded_string(ustrings.S(preferencias.medio));
p.bd_usuario := to_bounded_string(ustrings.S(preferencias.bd_usuario));
p.bd_password := to_bounded_string(ustrings.S(preferencias.bd_password));
p.bd_servidor := to_bounded_string(ustrings.S(preferencias.bd_servidor));
p.bd_puerto := preferencias.bd_puerto;
p.bd_nombre := to_bounded_string(ustrings.S(preferencias.bd_nombre));
p.administrador := preferencias.administrador;
write (fichero, p);
close (fichero);
end guardar;
procedure dar(preferencias : out tppreferencias) is
begin
preferencias.ruta := U(to_string(p.ruta));
preferencias.medio := U(to_string(p.medio));
preferencias.bd_usuario := U(to_string(p.bd_usuario));
preferencias.bd_password := U(to_string(p.bd_password));
preferencias.bd_servidor := U(to_string(p.bd_servidor));
preferencias.bd_puerto := p.bd_puerto;
preferencias.bd_nombre := U(to_string(p.bd_nombre));
preferencias.administrador := p.administrador;
end dar;
end preferencias;
--- NEW FILE ---
-----------------------------------------------------------------------------
-- TILDURE
-- Autor: Juan Manuel Perié Buil (44...@ce...)
-- Fichero: preferencias.ads
-- Fecha: 24 de abril de 2001
-- Proyecto: acdo
-- Descripción: Módulo para la gestión de las preferencias del programa
-----------------------------------------------------------------------------
with datos; use datos;
package preferencias is
procedure leer;
procedure guardar(preferencias : tppreferencias);
procedure dar(preferencias : out tppreferencias);
end preferencias;
--- NEW FILE ---
--
-- Copyright (C) 1996 Ada Resource Association (ARA), Columbus, Ohio.
-- Author: David A. Wheeler
--
package body Ustrings is
Input_Line_Buffer_Length : constant := 1024;
-- If an input line is longer, Get_Line will recurse to read in the line.
procedure Swap(Left, Right : in out Unbounded_String) is
-- Implement Swap. This is the portable but slow approach.
Temporary : Unbounded_String;
begin
Temporary := Left;
Left := Right;
Right := Temporary;
end Swap;
function Empty(S : Unbounded_String) return Boolean is
-- returns True if Length(S)=0.
begin
return (Length(S) = 0);
end Empty;
-- Implement Unbounded_String I/O by calling Text_IO String routines.
-- Get_Line gets a line of text, limited only by the maximum number of
-- characters in an Unbounded_String. It reads characters into a buffer
-- and if that isn't enough, recurses to read the rest.
procedure Get_Line (File : in File_Type; Item : out Unbounded_String) is
function More_Input return Unbounded_String is
Input : String (1 .. Input_Line_Buffer_Length);
Last : Natural;
begin
Get_Line (File, Input, Last);
if Last < Input'Last then
return To_Unbounded_String (Input(1..Last));
else
return To_Unbounded_String (Input(1..Last)) & More_Input;
end if;
end More_Input;
begin
Item := More_Input;
end Get_Line;
procedure Get_Line(Item : out Unbounded_String) is
begin
Get_Line(Current_Input, Item);
end Get_Line;
procedure Put(File : in File_Type; Item : in Unbounded_String) is
begin
Put(File, To_String(Item));
end Put;
procedure Put(Item : in Unbounded_String) is
begin
Put(Current_Output, To_String(Item));
end Put;
procedure Put_Line(File : in File_Type; Item : in Unbounded_String) is
begin
Put(File, Item);
New_Line(File);
end Put_Line;
procedure Put_Line(Item : in Unbounded_String) is
begin
Put(Current_Output, Item);
New_Line;
end Put_Line;
end Ustrings;
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright and authorship notice appear in all
-- copies and that both that copyright notice and this permission notice
-- appear in supporting documentation.
--
-- The ARA makes no representations about the suitability of this software
-- for any purpose. It is provided "as is" without express
-- or implied warranty.
--
--- NEW FILE ---
--
-- Copyright (C) 1996 Ada Resource Association (ARA), Columbus, Ohio.
-- Author: David A. Wheeler
--
with Text_IO, Ada.Strings.Unbounded;
use Text_IO, Ada.Strings.Unbounded;
package Ustrings is
-- This package provides a simpler way to work with type
-- Unbounded_String, since this type will be used very often.
-- Most users will want to ALSO with "Ada.Strings.Unbounded".
-- Ideally this would be a child package of "Ada.Strings.Unbounded".
--
-- This package provides the following simplifications:
-- + Shortens the type name from "Unbounded_String" to "Ustring".
-- + Creates shorter function names for To_Unbounded_String, i.e.
-- To_Ustring(U) and U(S). "U" is not a very readable name, but
-- it's such a common operation that a short name seems appropriate
-- (this function is needed every time a String constant is used).
-- It also creates S(U) as the reverse of U(S).
-- + Adds other subprograms, currently just "Swap".
-- + Other packages can use this package to provide other simplifications.
subtype Ustring is Unbounded_String;
function To_Ustring(Source : String) return Unbounded_String
renames To_Unbounded_String;
function U(Source : String) return Unbounded_String
renames To_Unbounded_String;
function S(Source : Unbounded_String) return String
renames To_String;
-- "Swap" is important for reuse in some other packages, so we'll define it.
procedure Swap(Left, Right : in out Unbounded_String);
function Empty(S : Unbounded_String) return Boolean;
-- returns True if Length(S)=0.
pragma Inline(Empty);
-- I/O Routines.
procedure Get_Line(File : in File_Type; Item : out Unbounded_String);
procedure Get_Line(Item : out Unbounded_String);
procedure Put(File : in File_Type; Item : in Unbounded_String);
procedure Put(Item : in Unbounded_String);
procedure Put_Line(File : in File_Type; Item : in Unbounded_String);
procedure Put_Line(Item : in Unbounded_String);
end Ustrings;
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright and authorship notice appear in all
-- copies and that both that copyright notice and this permission notice
-- appear in supporting documentation.
--
-- The ARA makes no representations about the suitability of this software
-- for any purpose. It is provided "as is" without express
-- or implied warranty.
--
--- NEW FILE ---
--------------------------------------------------------------------------
--TILDURE
--Autores: César Pérez Turrado <44...@ce...>
--Fichero: utiles.ads
--Fecha: 1 Mayo 2001
--Proyecto: ACDO
--Descripción:
--------------------------------------------------------------------------
with base_datos; use base_datos;
with Gtk.Main; use Gtk.Main;
package body utiles is
procedure salir is
begin
desconectar;
Main_Quit;
end;
end utiles;
--- NEW FILE ---
--------------------------------------------------------------------------
--TILDURE
--Autores: César Pérez Turrado <44...@ce...>
--Fichero: utiles.ads
--Fecha: 1 Mayo 2001
--Proyecto: ACDO
--Descripción:
--------------------------------------------------------------------------
package utiles is
procedure salir;
end utiles;
|
