PureBoard

Code: Alles auswählen

DeclareModule OWM

  ;:--------------------------------------------------------------------------
  ;:-
  ;:- Modul   : OpenWeatherMap (OWM)
  ;:- Author  : George Bisonte
  ;:- Date    : 15. Jan 2015
  ;:- PB      : 5.31
  ;:- OS      : Windows/Linux/MacOS
  ;:-           For License and more infos go to
  ;:-           http://www.openweathermap.org/API
  ;:- Credits : thx to ts-soft for ReceiveHTTPMemory()
  ;:-
  ;:- Compile it without Purifier (cause of a Purifier-Bug)
  ;:--------------------------------------------------------------------------
 
  Structure WEATHERDATA
   
    dwSize.l
   
    City.s
   
    Temp.i
    minTemp.i
    maxTemp.i
    unitTemp.s
   
    Humidity.i
    unitHumidity.s
   
    Pressure.i
    unitPressure.s
   
    IconUrl.s
    Icon.i
    Code.i
   
    Text.s
   
    LastUpdate.l
   
  EndStructure
 
  Declare GetWeatherData(City.s, *Weather.WEATHERDATA)
 
EndDeclareModule
Module OWM
 
  ;:--------------------------------------------------------------------------
  ;:-
  ;:- Modul   : OpenWeatherMap (OWM)
  ;:- Author  : George Bisonte
  ;:- Date    : 15. Jan 2015
  ;:- PB      : 5.31
  ;:- OS      : Windows/Linux/MacOS
  ;:-           For License and more infos go to
  ;:-           http://www.openweathermap.org/API
  ;:- Credits : thx to ts-soft for ReceiveHTTPMemory()
  ;:-
  ;:- Compile it without Purifier (cause of a Purifier-Bug)
  ;:--------------------------------------------------------------------------
 
  EnableExplicit
 
  Procedure ReceiveHTTPMemory(URL.s, BufferSize = 4096, Timeout = 5000)
   
    ;:- Original Author : TS-Soft
   
    If InitNetwork() = 0 : ProcedureReturn #False : EndIf
   
    Protected Connection, Time, Time2, Event, Size, Size2, SizeAll, pos
    Protected.s Server
    Protected *Mem, *Buffer, *Mem2
   
    Size = 1
   
    If LCase(Left(URL, 7)) <> "http://" : URL = "http://" + URL : EndIf
    Server = GetURLPart(URL, #PB_URL_Site)
    If Server = "" : ProcedureReturn #False : EndIf
    Connection = OpenNetworkConnection(Server, 80, #PB_Network_TCP)
    If Not Connection : ProcedureReturn #False : EndIf
    If BufferSize <= 0 : BufferSize = 4096 : EndIf
    *Buffer = AllocateMemory(BufferSize)
    If Not *Buffer
      ProcedureReturn #False
    EndIf
   
    SendNetworkString(Connection, "GET " + URL + " HTTP/1.0" + #LFCR$ + #LFCR$)
    Time = ElapsedMilliseconds()
    Repeat
      Event = NetworkClientEvent(Connection)
      If Event = #PB_NetworkEvent_Data
        Repeat
          Size = ReceiveNetworkData(Connection, *Buffer, BufferSize)
          If Size > 0
            Time = ElapsedMilliseconds()
            SizeAll + Size
            *Mem = ReAllocateMemory(*Mem, SizeAll)
            If *Mem
              CopyMemory(*Buffer, *Mem + (SizeAll - Size), Size)
            Else
              CloseNetworkConnection(Connection)
              FreeMemory(*Buffer)
              ProcedureReturn #False
            EndIf
          EndIf
        Until Size <= 0
      EndIf
      Time2 = ElapsedMilliseconds() - Time
    Until Time2 > Timeout Or Size <= 0
    CloseNetworkConnection(Connection)
    FreeMemory(*Buffer)
    If Time2 > Timeout
      If *Mem : FreeMemory(*Mem) : EndIf
      ProcedureReturn #False
    EndIf
    pos = FindString(PeekS(*mem, -1, #PB_UTF8), #CRLF$ + #CRLF$, 1) - 1
    pos = Len(#CRLF$ + #CRLF$) + pos
    Size2 = MemorySize(*Mem) - pos
    *Mem2 = AllocateMemory(Size2)
    If *Mem2
      CopyMemory(*Mem + pos, *Mem2, Size2)
      FreeMemory(*Mem)
      ProcedureReturn *Mem2
    EndIf
    FreeMemory(*Mem)
   
    ProcedureReturn #False
  EndProcedure
  Procedure RFindString(String.s, StringToFind.s, StartPosition = 1)

    Protected Found
   
    Repeat
      Found = FindString(String, StringToFind, StartPosition)
      If Found
        StartPosition = Found + 1
      EndIf
    Until Found = 0
   
    ProcedureReturn StartPosition - 1
   
  EndProcedure
  
  Procedure.s GetCityName(Name.s)
    
    If Name <> ""
      Name = LCase(ReplaceString(UCase(Name), "Ü", "UE"))
      Name = LCase(ReplaceString(UCase(Name), "Ö", "OE"))
      Name = LCase(ReplaceString(UCase(Name), "Ä", "AE"))
      Name = LCase(ReplaceString(UCase(Name), "ß", "SS"))
    EndIf
    
    ProcedureReturn Name
    
  EndProcedure
  
  Procedure GetWeatherData(City.s, *Weather.WEATHERDATA)
   
    Protected *Mem, xmlString.s, *ChildNode, *Node, Weather, XML, h.s, i, oCity.s
    Protected NewMap Nodes()
    
    oCity = City : City = GetCityName(oCity)
    
    Debug City
    If Not *Weather : ProcedureReturn #False : EndIf
    If *Weather\dwSize <> SizeOf(WEATHERDATA) : ProcedureReturn #False : EndIf
   
    *Mem = ReceiveHTTPMemory("http://api.openweathermap.org/data/2.5/weather?q=" + City + "&mode=xml&units=metric")
    If Not *Mem : ProcedureReturn #False : EndIf
   
    xmlString = PeekS(*Mem, -1, #PB_Ascii) : FreeMemory(*Mem)   
   
    ;:- If the city is not found
    If FindString(LCase(xmlString), "message") And FindString(LCase(xmlString), "error:")
      *Weather\City = "Error : Not found city"
      ProcedureReturn #False
    EndIf
   
    ;:- Cut off some characters at the end of the string.
    xmlString = Left(xmlString, RFindString(LCase(xmlString), "</current>") + Len("</current>"))
   
    ;:- parse the xml data
    XML = ParseXML(#PB_Any, xmlString)
   
    If XML
     
      ;:- get all nodes
      *ChildNode = ChildXMLNode(MainXMLNode(XML))
      While *ChildNode <> 0
        Nodes(LCase(GetXMLNodeName(*ChildNode))) = *ChildNode
        *ChildNode = NextXMLNode(*ChildNode)
      Wend
     
      With *Weather
       
        \City = City
        i = FindString(City, ",") : If i : \City = Left(City, i-1) : EndIf
       
        ;:- parse it
        *Node = Nodes("temperature")
        If *Node
          If ExamineXMLAttributes(*Node)
            While NextXMLAttribute(*Node)
              Select LCase(XMLAttributeName(*Node))
                Case "value"
                  \Temp = Val(XMLAttributeValue(*Node))
                Case "min"
                  \minTemp = Val(XMLAttributeValue(*Node))
                Case "max"
                  \maxTemp = Val(XMLAttributeValue(*Node))
                Case "unit"
                  \unitTemp = XMLAttributeValue(*Node)
                  \unitTemp = UCase(Left(\unitTemp,1)) + Mid(\unitTemp, 2)
              EndSelect     
            Wend
          EndIf   
        EndIf
       
        *Node = Nodes("humidity")
        If *Node
          If ExamineXMLAttributes(*Node)
            While NextXMLAttribute(*Node)
              Select LCase(XMLAttributeName(*Node))
                Case "value"
                  \Humidity = Val(XMLAttributeValue(*Node))
                Case "unit"
                  \unitHumidity = XMLAttributeValue(*Node)
              EndSelect     
            Wend
          EndIf   
        EndIf
       
        *Node = Nodes("weather")
        If *Node
          If ExamineXMLAttributes(*Node)
            While NextXMLAttribute(*Node)
              Select LCase(XMLAttributeName(*Node))
                Case "value"
                  \Text = XMLAttributeValue(*Node)
                Case "icon"
                  \IconUrl = "http://openweathermap.org/img/w/" + XMLAttributeValue(*Node) + ".png"
                  *Mem = ReceiveHTTPMemory(\IconUrl)
                  If *Mem
                    \Icon = CatchImage(#PB_Any, *Mem)
                    FreeMemory(*Mem)
                  EndIf
                Case "number"
                  \Code = Val(XMLAttributeValue(*Node))
              EndSelect     
            Wend
          EndIf   
        EndIf
       
        *Node = Nodes("pressure")
        If *Node
          If ExamineXMLAttributes(*Node)
            While NextXMLAttribute(*Node)
              Select LCase(XMLAttributeName(*Node))
                Case "value"
                  \Pressure = Val(XMLAttributeValue(*Node))
                Case "unit"
                  \unitPressure = XMLAttributeValue(*Node)
              EndSelect     
            Wend
          EndIf   
        EndIf
       
        *Node = Nodes("lastupdate")
        If *Node
          If ExamineXMLAttributes(*Node)
            While NextXMLAttribute(*Node)
              Select LCase(XMLAttributeName(*Node))
                Case "value"
                  h = LCase(XMLAttributeValue(*Node))
                  Debug h
                  \LastUpdate = ParseDate("%yyyy-%mm-%ddt%hh:%ii:%ss", h)
                  Debug \LastUpdate
              EndSelect     
            Wend
          EndIf   
        EndIf
        *Weather\City = oCity
      EndWith
     
      ProcedureReturn #True
     
    Else
      ProcedureReturn #False
    EndIf
   
   
  EndProcedure
 
EndModule

;:- Demo

CompilerIf #PB_Compiler_IsMainFile
EnableExplicit

Define x, y, Event, Font1 = LoadFont(#PB_Any, "Verdana", 12, #PB_Font_Bold), Font2 = LoadFont(#PB_Any, "Verdana", 8, #PB_Font_Bold)

Define Weather.OWM::WEATHERDATA

UsePNGImageDecoder()

Weather\dwSize = SizeOf(OWM::WEATHERDATA)

If OWM::GetWeatherData("Neumünster,de", @Weather)
 
 
  OpenWindow(0, 0, 0, 320, 120, "Test", #PB_Window_ScreenCentered|#PB_Window_SystemMenu)
 
  CanvasGadget(0, 10, 10, 300, 100)
 
  If StartDrawing(CanvasOutput(0))
   
    Box(0, 0, OutputWidth(), OutputHeight(), 0)
    DrawingMode(#PB_2DDrawing_Gradient)
    BackColor($F0F0F0) : FrontColor($F0F0F0)
    GradientColor(0.500, $A0A0A0)
    LinearGradient(0,0,0,OutputHeight())
    Box(1,1,OutputWidth()-2,OutputHeight()-2, RGB(255,0,0))
    If IsImage(Weather\Icon) : DrawAlphaImage(ImageID(Weather\Icon), 1, 1, 255) : EndIf
    DrawingMode(#PB_2DDrawing_Default|#PB_2DDrawing_Transparent)
    DrawingFont(FontID(Font1))
    DrawText(5, 48, Weather\City, 0)
    DrawingFont(FontID(Font2))
    DrawText(70, 5, "Temp : " + Str(Weather\Temp) + Chr(176) + " " +Left(Weather\unitTemp,1), 0)
    DrawText(70, 5 + TextHeight("T"), "at " + FormatDate("%hh:%ii", Weather\LastUpdate), 0)
    y = OutputHeight() - TextHeight("O") - 2
    x = OutputWidth() - TextWidth("by OpenWeatherMap.org") - 2
    DrawText(x, y, "by OpenWeatherMap.org", RGB( 80, 80, 80))
    StopDrawing()
   
  EndIf
 
  GadgetToolTip(0, Weather\Text)
 
  Repeat
    Event = WaitWindowEvent()
  Until Event = #PB_Event_CloseWindow
 
EndIf
CompilerEndIf

Code: Alles auswählen

  *Mem = ReAllocateMemory(*Mem, SizeAll)   ; Zeile 94