Modify a MEM file

[Antonio Linares]

Code: Select all  Expand view

*------------------------------------------------------------
* EDITMEM.PRG - Programa para modificar archivos .MEM
*
* Autor: Julio César Mosquera - Claudio VOSKIAN
*
* Contenido:
*
* ADDVAR....: Agrega una variable al .MEM
* ADMIN.....: Administrar las funciones del programa
* CENTRAR ..: Centrar un texto
* CONFIRMA..: Pide la confirmación de una acción
* DELVAR....: Elimina una variable del .MEM
* LECMEM....: Lee el archivo .MEM y carga sus variables al vector
* MODVAR....: Modifica una variable del .MEM
* PRESS.....: Pone un mensaje en la última línea y espera una tecla
* VMEM......: Validación del nombre del archivo
* VNOMVAR...: Valida nombre de la variable
* VTIPVAR...: Valida el tipo de la variable
* VVALVAR...: Valida el contenido de la variable
*------------------------------------------------------------

*------------------------------------------------------------
* Rutina.......: EM.PRG
* Objetivo.....: Programa para modificar archivos .MEM
*------------------------------------------------------------

external LEFT,RIGHT,DESCEND,ALLTRIM,STRZERO
memvar x, y

*
function main(x, y)
*------------
local getlist := {}

private z_6_mem, z_6_salir, z_6_grabar, z_6_choice, z_6_nomvar, z_6_valvar,;
        z_6_accion, z_6_inic, z_6_1, z_6_2, z_6_3, z_6_4, z_6_print, z_6_fila

set scoreboard off
set date british
set century on
set confirm on
set exact on
set fixed on
set decimals to 6

setmode(25,80)

m->z_6_print = "printer"
if valtype(x) # "C"
   x = space(255)
else

   if valtype(y) = "C"
      x += y
   endif

   if "/P" $ upper(x)
      set printer to printer.prn
      m->z_6_print = "file"
      x = alltrim(strtran(x, "/P", '', 1, 1))
   endif
endif

m->z_6_mem = x
m->z_6_salir = .f.
m->z_6_inic = .t.

while !m->z_6_salir
   private z_6_var // array(500)
   private z_6_cvar

   m->z_6_var := array(500)

   clear screen
   setcolor("W+")
   centrar(0, 80, "Editor de .MEM")
   setcolor("W/N")

   if !empty(m->z_6_mem)
      m->z_6_mem = upper(alltrim(m->z_6_mem))
      if !file(m->z_6_mem)
         if right(m->z_6_mem, 4) # ".MEM" .and. rat(".", m->z_6_mem) <= rat("\", m->z_6_mem)
            m->z_6_mem = m->z_6_mem + ".MEM"
         endif
      endif
   endif

   @ 3, 0 say "Nombre del MEM a editar:"
   if !m->z_6_inic .or. empty(m->z_6_mem)
      m->z_6_mem = pad(m->z_6_mem, 128)
      @ 3,25 get m->z_6_mem picture "@!S30" valid vmem()
      m->z_6_salir = !doread(getlist)
   else
      @ 3,25 say m->z_6_mem
   endif

   m->z_6_inic = .f.
   if !m->z_6_salir
      admin()
   endif
enddo

setcolor('')
set cursor on
clear screen

return nil

*
function vmem           && validación del nombre del archivo
*------------
local ret, k

ret = .t.
if empty(m->z_6_mem)
   press("Debe informar el nombre")
   ret = .f.
else
   k = alltrim(m->z_6_mem)
   if !file(k)
      if right(k, 4) # ".MEM" .and. !("." $ k)
         k += ".MEM"
      endif
   endif
   if file(k)
      m->z_6_mem = k
   else
      press("Archivo inexistente")
      ret = .f.
   endif
endif

return ret

*
function admin          && Administrar las funciones del programa
*-------------
lecmem()

if m->z_6_cvar > 0
   restore from (m->z_6_mem) additive

   m->z_6_1 =  5                && fila superior izquierda
   m->z_6_2 =  5                && columna superior izquierda
   m->z_6_3 = 14                && fila inferior derecha
   m->z_6_4 = m->z_6_2 + 16     && columna superior derecha

   setcolor("W+")
   @ m->z_6_1 + 1, m->z_6_2 + 40 say "Agrega variable    [INS]"
   @ m->z_6_1 + 2, m->z_6_2 + 40 say "Elimina variable   [DEL]"
   @ m->z_6_1 + 3, m->z_6_2 + 40 say "Consulta/Modifica  [ENTER]"
   @ m->z_6_1 + 4, m->z_6_2 + 40 say "Graba .mem y sale  [G]"
   @ m->z_6_1 + 5, m->z_6_2 + 40 say "Sale sin grabar    [ESC]"
   @ m->z_6_1 + 6, m->z_6_2 + 40 say "Imprime            [I]"
   @ m->z_6_1 + 7, m->z_6_2 + 40 say "Copia variable     [C]"

   setcolor("W/N")
   @ m->z_6_1, m->z_6_2 to m->z_6_3, m->z_6_4 double

   setcolor("W+")
   centrar(m->z_6_1, 13, " Variables ", m->z_6_2 + 2)
   setcolor("W/N")

   while .t.
      @ m->z_6_1 + 1, m->z_6_2 + 1 clear to m->z_6_3 - 1, m->z_6_4 - 1
      m->z_6_choice = achoice(m->z_6_1 + 1, m->z_6_2 + 2, m->z_6_3 - 1, m->z_6_4 - 2, m->z_6_var, .t., "fmenu", m->z_6_choice)

      do case
         case m->z_6_choice # 0 .and. m->z_6_accion = "M"
              * modificar la variable
              @ m->z_6_fila, m->z_6_2 - 2 say ">>"
              modvar()
              @ m->z_6_fila, m->z_6_2 - 2 say "  "
         case m->z_6_choice # 0 .and. m->z_6_accion = "C"
              * copiar la variable
              @ m->z_6_fila, m->z_6_2 - 2 say ">>"
              if copvar()
                 &(m->z_6_nomvar) := m->z_6_valvar
                 press("Variable copiada")
              endif
              @ m->z_6_fila, m->z_6_2 - 2 say "  "
         case m->z_6_choice # 0 .and. m->z_6_accion = "D"
              * eliminar la variable
              @ m->z_6_fila, m->z_6_2 - 2 say ">>"
              m->z_6_nomvar = LEFT(m->z_6_var[m->z_6_choice],10)
              if confirma("la eliminación de " + trim(m->z_6_nomvar))
                 adel(m->z_6_var, m->z_6_choice)
                 m->z_6_cvar = m->z_6_cvar - 1
                 release &(m->z_6_nomvar)
              endif
              @ m->z_6_fila, m->z_6_2 - 2 say "  "
         case m->z_6_accion = "A"
              * agrego la variable
              &(m->z_6_nomvar) := iif(type("m->z_6_valvar") = "C", substr(m->z_6_valvar, 2, len(m->z_6_valvar) - 2), m->z_6_valvar)
              m->z_6_choice = m->z_6_cvar
         case m->z_6_accion = "G"
              * grabar
              save to (m->z_6_mem) all except z_6_*
              EXIT
         otherwise
              * salida!
              EXIT
      endcase
   enddo
endif

return .f.

*
function modvar         && Modifica una variable
*--------------
local getlist := {}
local Pant := savescreen(0, 0, 24, 79)
private tipvar
private oldvar, valvar, oldtip, picvar

m->z_6_nomvar = space(10)
m->tipvar := " "
m->oldvar := LEFT(m->z_6_var[m->z_6_choice],10)
m->oldtip := m->tipvar := type(m->oldvar)
m->valvar := ''

@ 16, 1 say  "Tipo anterior: " + m->tipvar
@ 17, 0 say "Valor anterior:"
if iif(type(m->oldvar) = "C", len(&(m->oldvar)) > 30, .f.)
   @ 17, 16 say left(&(m->oldvar), 30)
   setcolor("W+")
   @ 17, 47 say ">> sigue >>"
   setcolor("W")
else
   @ 17, 16 say &(m->oldvar)
endif

@ 18, 4 say "Nuevo tipo:" get m->tipvar picture "@A!" valid vtipvar()
if doread(getlist)
   @ 19, 3 say "Nuevo valor:" get m->valvar picture m->picvar valid vvalvar()

   if m->tipvar = "C"
      if m->valvar = '""'
         keyboard chr(4)
         readinsert(.t.)
      endif
   endif

   if doread(getlist)
      if type("m->valvar") = "C"        && Saco comillas, si las hay!
         m->valvar = trim(m->valvar)
         if left(m->valvar,1) $ ["']
            m->valvar = substr(m->valvar, 2, len(m->valvar) - 2)
         endif
      endif
      &(m->oldvar) = m->valvar
      m->z_6_var[m->z_6_choice] = LEFT( m->oldvar + SPACE(10), 10) + " " + type(m->oldvar)
   endif
   readinsert(.f.)
endif

restscreen(0, 0, 24, 79, Pant)

return .f.

*
function vtipvar        && valida el tipo de la variable
*---------------
local ret

do case
   case lastkey() = 5
        ret = .t.
   case empty(m->tipvar)
        press("No puede ser vacío")
        ret = .f.
   case m->tipvar $ "CNDL"
        ret = .t.
        do case
           case m->tipvar = "C"
                if m->tipvar = m->oldtip
                   m->valvar = pad('"' + &(m->oldvar) + '"', 255)
                else
                   m->valvar = '""' + space(253)
                endif
                m->picvar = "@S30"
           case m->tipvar = "D"
                if m->tipvar = m->oldtip
                   m->valvar = &(m->oldvar)
                else
                   m->valvar = ctod('')
                endif
                m->picvar = ''
           case m->tipvar = "L"
                if m->tipvar = m->oldtip
                   m->valvar = &(m->oldvar)
                else
                   m->valvar = .f.
                endif
                m->picvar = "L"
           case m->tipvar = "N"
                if m->tipvar = m->oldtip
                   m->valvar = &(m->oldvar)
                else
                   m->valvar = 0
                endif
                m->picvar = "99999999999.999999"
        endcase
   otherwise
        press("Debe ser C, N, D o L")
        ret = .f.
endcase

return ret

*
function vvalvar        && Valida el contenido de la variable
*---------------
local ret, k, h

if lastkey() = 5
   ret = .t.
elseif m->tipvar = "C"
   k = alltrim(m->valvar)
   if empty(k)
      ret = .f.
      press("Debe incluir comillas")
   else
      h = left(k, 1)
      if h = "&"

         H = SUBSTR(K, 2)
         m->VALVAR = &H
         if type("m->VALVAR") = "C"
*           if empty(m->valvar)
               m->valvar = '"' + m->valvar + '"'
*           endif
         endif
         RET = .T.

      ELSE

         if !h $ ["']
            press("Debe comenzar con comillas o '&'")
            ret = .f.
         else
            if right(k, 1) = h .and. !(h $ substr(k, 2, len(k) - 2))
               ret = .t.
            else
               press("Comillas incorrectas, o falta operador '&'")
               ret = .f.
            endif
         endif
      ENDIF
   endif
else
   ret = .t.
endif

return ret

*
function addvar         && agrega una variable
*--------------
local getlist := {}
private tipvar, pant, k, picvar, oldtip, valvar

m->oldtip = "X"

m->pant = savescreen(0, 0, 24, 79)
m->tipvar = " "
m->z_6_nomvar = space(10)
@ 16, 0 say "Nombre........:" get m->z_6_nomvar picture "@!"  valid vnomvar(.f.)
@ 17, 0 say "Tipo..........:" get m->tipvar     picture "@A!" valid vtipvar()
if doread(getlist)

   if m->tipvar = "C"
      if m->valvar == '""' + space(253)
         keyboard chr(4)
         readinsert(.t.)
      endif
   endif

   @ 19, 0 say "Valor.........:" get m->valvar picture m->picvar valid vvalvar()
   if doread(getlist)
      m->z_6_nomvar = trim(m->z_6_nomvar)
      m->z_6_cvar = m->z_6_cvar + 1
      m->z_6_valvar = iif(type("m->valvar") = "C", trim(m->valvar), m->valvar)
      m->z_6_var[m->z_6_cvar] = LEFT( m->z_6_nomvar + SPACE(10), 10) + " " + M->TIPVAR
   endif
   readinsert(.f.)
else
   m->z_6_nomvar = ''
endif

restscreen(0, 0, 24, 79, m->pant)

return .f.

*------------------------------------------------------------
* Rutina.......: VNOMVAR
* Objetivo.....: Valida nombre de la variable
* Parámetros...: EXISTA (Lógica) Si .T. valido que exista. Si .F. valido que no exista
*------------------------------------------------------------

function vnomvar
*---------------
parameters exista
local ret

ret = .t.
if empty(m->z_6_nomvar)
   ret = .f.
   press("No puede ser vacío")
else
   if !validname(m->z_6_nomvar)
      ret = .f.
      press("Nombre de variable inválido")
   else
      if mod_ascan(m->z_6_var, m->z_6_nomvar, 1, m->z_6_cvar) > 0
         if !m->exista
            ret = .f.
            press("Variable existente")
         endif
      else
         if m->exista
            ret = .f.
            press("Variable inexistente")
         endif
      endif
   endif
endif

return ret

*
function validname
*-----------------
local k,ret

parameters valvar

m->valvar = alltrim(m->valvar)
k = left(m->valvar,1)
ret = .t.
if !k $ "ABCDEFGHIJKLMNOPQRSTUVWXYZ_"
   ret = .f.
else
   for k = 2 to len(m->valvar)
       if !substr(m->valvar,k,1) $ "ABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789"
          ret = .f.
          EXIT
       endif
   next
endif
return ret

*
function copvar         && copia una variable sobre otra ya existente
*--------------
local getlist := {}
local pant := savescreen(0, 0, 24, 79)
local ret
local k
private valvar

m->valvar = LEFT(m->z_6_var[m->z_6_choice],10)

m->z_6_nomvar = space(10)
@ 16, 0 say "Variable origen.: " + m->valvar
@ 17, 0 say "Tipo............: " + type(m->valvar)
@ 18, 0 say "Contenido.......:"
if iif(type(m->valvar) = "C", len(&(m->valvar)) > 30, .f.)
   @ 18, 18 say left(&(m->valvar), 30)
   setcolor("W+")
   @ 18, 49 say ">> sigue >>"
   setcolor("W")
else
   @ 18, 18 say &(m->valvar)
endif

@ 19, 0 say "Variable destino:" get m->z_6_nomvar picture "@!" valid vcopvar()
ret = doread(getlist)

if ret
   k = mod_ascan(m->z_6_var, m->z_6_nomvar, 1, m->z_6_cvar)
   m->z_6_valvar = &(m->valvar)
   m->z_6_nomvar = LEFT(m->z_6_var[k],10)
endif

restscreen(0, 0, 24, 79, pant)

return ret

*
function vcopvar        && valida el nombre de la variable destino de una copia
*---------------
local ret,k

ret = .t.
if empty(m->z_6_nomvar)
   ret = .f.
   press("No puede ser vacío")
else
   if !validname(m->z_6_nomvar)
      ret = .f.
      press("Nombre de variable inválido")
   else
      k = mod_ascan(m->z_6_var, m->z_6_nomvar, 1, m->z_6_cvar)
      if k = 0
         m->z_6_cvar ++
         m->z_6_var[m->z_6_cvar] = LEFT(m->z_6_nomvar + SPACE(10), 10) +" "+ type(m->valvar)
      else
         m->z_6_var[m->k] = LEFT( m->z_6_nomvar + SPACE(10), 10) +" "+ type(m->valvar)
      endif
   endif
endif

return ret

*
function lecmem         && Lee el archivo y carga sus variables al vector
*--------------
local buffer, tipo, prox, k

buffer = memoread(m->z_6_mem)

m->z_6_cvar = 0
while !empty(buffer)
   m->z_6_cvar ++
   k = at(chr(0), buffer)
   tipo = substr(buffer, 12, 1)
   do case
      case tipo $ "N╬"       && 206
           * Numérico
           prox = 41
           TIPO = "N"
      case tipo $ "L╠"       && 204
           * Lógico
           prox = 34
           TIPO = "L"
      case tipo $ "D─"       && 196
           * Fecha
           prox = 41
           TIPO = "D"
      case tipo $ "C├"       && 195
           * Carácter
           prox = 33 + asc(substr(buffer, 17)) + asc(substr(buffer, 18)) * 256
           TIPO = "C"
      otherwise
           press("Archivo .mem corrupto")
           break
   endcase
   m->z_6_var[m->z_6_cvar] = LEFT( left(buffer, k - 1) + SPACE(10), 10) +" "+ TIPO
   buffer = substr(buffer, prox)
   if len(buffer) = 1
      buffer = ''
   endif
enddo
if m->z_6_cvar = 0
   press("No hay variables a listar")
endif

return .f.

*
function fmenu          && Función para achoice de menu
*-------------
parameters modo
local tecla, ret

ret = 2
tecla = lastkey()
do case
   case m->modo = 0
        * Idle
   case m->modo = 1
        * Cursor past top of list
        keyboard chr(30)  && Ctrl Pg-Dn
   case m->modo = 2
        * Cursor past end of list
        keyboard chr(31)  && Ctrl Pg-Up
   case m->modo = 3
        * Keystroke exception
        do case
           case tecla = 1
                * Home
                keyboard chr(31)        && Ctrl Pg-Up
           case tecla = 6
                * End
                keyboard chr(30)        && Ctrl Pg-Dn
           case tecla = 7
                * Delete
                m->z_6_accion = "D"
                m->z_6_fila = row()
                ret = 1
           case tecla = 13
                * Enter
                m->z_6_accion = "M"
                m->z_6_fila = row()
                ret = 1
           case tecla = 22
                * Insert
                addvar()
                if !empty(m->z_6_nomvar)
                   m->z_6_accion = "A"
                   ret = 0
                endif
           case tecla = 27
                * Escape
                if confirma("la pérdida de los cambios realizados")
                   m->z_6_accion = "S"
                   ret = 0
                endif
           case chr(tecla) $ "Cc"
                * Copiar
                m->z_6_accion = "C"
                m->z_6_fila = row()
                ret = 1
           case chr(tecla) $ "Ii"
                * Imprimir
                prmem()
           case chr(tecla) $ "Gg"
                * Grabar
                if confirma("la grabación de los cambios")
                   m->z_6_accion = "G"
                   ret = 0
                endif
           otherwise
*               tone(600, 1)
        endcase
   case m->modo = 4
        * No item selectable
        * No puede pasar en este caso
endcase

return ret

*
function doread(getlist)        && realiza la lectura con cursor visible
*--------------
set cursor on
read
set cursor off

return lastkey() # 27

*------------------------------------------------------------
* Rutina.......: PRESS
* Objetivo.....: Pone un mensaje en la última línea y espera una tecla
* Parámetros...: TEXTO (Carácter) Mensaje a mostrar
*------------------------------------------------------------

function press
*-------------
parameters texto
local oldcolor

oldcolor = setcolor("W+")
centrar(24,80, m->texto + ". Pulse una tecla.")
tone(600,1)
inkey(10)
setcolor(oldcolor)
@ 24,0

return .f.

*------------------------------------------------------------
* Rutina.......: CONFIRMA
* Objetivo.....: Pide la confirmación de una acción
* Parámetros...: TEXTO (Carácter) Mensaje a mostrar
*------------------------------------------------------------

function confirma
*----------------
parameters texto
local tecla, oldcolor

oldcolor = setcolor("W+")
centrar(24,80, "¿Confirma " + m->texto + "? (S/N)")
tecla = "x"
while !tecla $ "SN"+chr(27)
   tone(600,1)
   tecla = upper(chr(inkey(0)))
enddo
setcolor(oldcolor)
@ 24, 0

return tecla = "S"

*------------------------------------------------------------
* Rutina.......: CENTRAR
* Objetivo.....: Centrar un texto
* Parámetros...: FILA   (Numérico) Fila donde se centra el texto
*                ANCHO  (Numérico) Ancho de la fila donde se centra
*                TEXTO  (Carácter) Texto a centrar
*                MARGEN (Numérico) Margen izquierdo (opcional)
*------------------------------------------------------------

function centrar
*---------------
parameters fila, ancho, texto, margen

if type("m->margen") # "N"
   m->margen = 0
endif
@ m->fila, m->margen + (m->ancho - len(m->texto)) / 2 say m->texto

return .f.

*
function prmem          && Imprime el .MEM
*-------------
local i,oo,tipo

if confirma("el comienzo de la impresión" + iif(m->z_6_print = "file", " a disco", ''))
   if iif(m->z_6_print = "printer", isprinter(), .t.)
      set device to print
      set print on
      set console off
      tipo = "Listado de variables en " + m->z_6_mem
      centrar(prow() + 1, 80, tipo)
      centrar(prow() + 1, 80, replicate("=", len(tipo)))
      @ prow() + 2, 0 say replicate("-", 80)
      @ prow() + 1, 0 say "Variable   Tipo Contenido"
      @ prow() + 1, 0 say replicate("-", 80)
      *                    1234567890  1   1234567890123456789012345678901234567890123456789012345678901234
      *                    01234567890123456789012345678901234567890123456789012345678901234567890123456789
      for i = 1 to m->z_6_cvar
          oo = LEFT(m->z_6_var[i],10)
          tipo = type(oo)
          @ prow() + 1,  0 say oo
          @ prow(),     12 say tipo
          if tipo = "C"
             oo = '"' + &oo + '"'
             @ prow(), 16 say left(oo, 64)
          elseif m->tipo = "N"
             @ prow(), 16 say &oo picture "99999999999.999999"
          else
             @ prow(), 16 say &oo
          endif
      next
      set device to screen
      set print off
      set console on
      press("Impresión terminada")
   endif
endif

return .f.

*
function mod_ascan(vector,valor,desde,hasta)
*-----------------
local k,l,pos

l = left(valor,10)
pos = 0
for k = desde to hasta
    if l == left(vector[k],10)
       pos = k
       EXIT
    endif
next

return pos